Hello community,
here is the log from the commit of package ghc-persistent-template for
openSUSE:Factory checked in at 2019-04-28 20:13:25
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-persistent-template (Old)
and /work/SRC/openSUSE:Factory/.ghc-persistent-template.new.5536 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent-template"
Sun Apr 28 20:13:25 2019 rev:17 rq:698558 version:2.7.0
Changes:
--------
---
/work/SRC/openSUSE:Factory/ghc-persistent-template/ghc-persistent-template.changes
2019-02-17 12:20:23.500216222 +0100
+++
/work/SRC/openSUSE:Factory/.ghc-persistent-template.new.5536/ghc-persistent-template.changes
2019-04-28 20:13:29.582417002 +0200
@@ -1,0 +2,9 @@
+Thu Apr 18 02:03:26 UTC 2019 - [email protected]
+
+- Update persistent-template to version 2.7.0.
+ ## 2.7.0
+
+ * Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and
`AtLeastOneUniqueKey` classes. Automatically generates instances for these
classes based on how many unique keys the entity definition gets. This changes
requires `UndecidableInstances` to be enabled on each module that generates
entity definitions. [#885](https://github.com/yesodweb/persistent/pull/885)
+ * Removed deprecated `sqlOnlySettings`. Please use `sqlSettings` instead.
[#894](https://github.com/yesodweb/persistent/pull/894)
+
+-------------------------------------------------------------------
Old:
----
persistent-template-2.6.0.tar.gz
New:
----
persistent-template-2.7.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-persistent-template.spec ++++++
--- /var/tmp/diff_new_pack.mfyaVp/_old 2019-04-28 20:13:30.270416573 +0200
+++ /var/tmp/diff_new_pack.mfyaVp/_new 2019-04-28 20:13:30.270416573 +0200
@@ -19,7 +19,7 @@
%global pkg_name persistent-template
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 2.6.0
+Version: 2.7.0
Release: 0
Summary: Type-safe, non-relational, multi-backend persistence
License: MIT
@@ -27,7 +27,6 @@
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
BuildRequires: ghc-Cabal-devel
-BuildRequires: ghc-aeson-compat-devel
BuildRequires: ghc-aeson-devel
BuildRequires: ghc-bytestring-devel
BuildRequires: ghc-containers-devel
@@ -37,7 +36,6 @@
BuildRequires: ghc-path-pieces-devel
BuildRequires: ghc-persistent-devel
BuildRequires: ghc-rpm-macros
-BuildRequires: ghc-tagged-devel
BuildRequires: ghc-template-haskell-devel
BuildRequires: ghc-text-devel
BuildRequires: ghc-transformers-devel
++++++ persistent-template-2.6.0.tar.gz -> persistent-template-2.7.0.tar.gz
++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.6.0/ChangeLog.md
new/persistent-template-2.7.0/ChangeLog.md
--- old/persistent-template-2.6.0/ChangeLog.md 2019-01-27 14:37:47.000000000
+0100
+++ new/persistent-template-2.7.0/ChangeLog.md 2019-04-17 21:50:18.000000000
+0200
@@ -1,3 +1,8 @@
+## 2.7.0
+
+* Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and
`AtLeastOneUniqueKey` classes. Automatically generates instances for these
classes based on how many unique keys the entity definition gets. This changes
requires `UndecidableInstances` to be enabled on each module that generates
entity definitions. [#885](https://github.com/yesodweb/persistent/pull/885)
+* Removed deprecated `sqlOnlySettings`. Please use `sqlSettings` instead.
[#894](https://github.com/yesodweb/persistent/pull/894)
+
## 2.6.0
* [persistent#846](https://github.com/yesodweb/persistent/pull/846): Improve
error message when marshalling fails
* [persistent#826](https://github.com/yesodweb/persistent/pull/826): Change
`Unique` derive `Show`
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.6.0/Database/Persist/TH.hs
new/persistent-template-2.7.0/Database/Persist/TH.hs
--- old/persistent-template-2.6.0/Database/Persist/TH.hs 2019-01-27
14:37:47.000000000 +0100
+++ new/persistent-template-2.7.0/Database/Persist/TH.hs 2019-04-16
04:46:49.000000000 +0200
@@ -1,19 +1,13 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}
-#if !MIN_VERSION_base(4,8,0)
--- overlapping instances is for automatic lifting
--- while avoiding an orphan of Lift for Text
-{-# LANGUAGE OverlappingInstances #-}
-#endif
-
-- | This module provides utilities for creating backends. Regular users do not
-- need to use this module.
module Database.Persist.TH
@@ -34,7 +28,6 @@
, EntityJSON(..)
, mkPersistSettings
, sqlSettings
- , sqlOnlySettings
-- * Various other TH functions
, mkMigrate
, mkSave
@@ -44,48 +37,47 @@
, derivePersistFieldJSON
, persistFieldFromEntity
-- * Internal
- , packPTH
, lensPTH
, parseReferences
+ , AtLeastOneUniqueKey(..)
+ , OnlyOneUniqueKey(..)
) where
import Prelude hiding ((++), take, concat, splitAt, exp)
-import Database.Persist
-import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql)
-import Database.Persist.Quasi
-import Language.Haskell.TH.Lib (
-#if MIN_VERSION_template_haskell(2,11,0)
- conT,
-#endif
- varE)
-import Language.Haskell.TH.Quote
-import Language.Haskell.TH.Syntax
+
+import Control.Monad (forM, unless, (<=<), mzero)
+import Data.Aeson
+ ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object
+ , Value (Object), (.:), (.:?)
+ , eitherDecodeStrict'
+ )
import Data.Char (toLower, toUpper)
-import Control.Monad (forM, (<=<), mzero)
-import qualified System.IO as SIO
-import Data.Text (pack, Text, append, unpack, concat, uncons, cons,
stripPrefix, stripSuffix)
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8)
-import qualified Data.Text.IO as TIO
+import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.List (foldl')
+import qualified Data.List.NonEmpty as NEL
+import qualified Data.Map as M
import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe)
import Data.Monoid (mappend, mconcat)
-import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident))
-import qualified Data.Map as M
-import qualified Data.HashMap.Strict as HM
-import Data.Aeson.Compat
- ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object
- , Value (Object), (.:), (.:?)
- , eitherDecodeStrict'
- )
-import Control.Applicative as A (pure, (<$>), (<*>))
-import Database.Persist.Sql (sqlType)
import Data.Proxy (Proxy (Proxy))
+import Data.Text (pack, Text, append, unpack, concat, uncons, cons,
stripPrefix, stripSuffix)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.IO as TIO
+import GHC.Generics (Generic)
+import GHC.TypeLits
+import Language.Haskell.TH.Lib (conT, varE)
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+import qualified System.IO as SIO
+import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident))
import Web.PathPieces (PathPiece(..))
import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..))
-import GHC.Generics (Generic)
-import qualified Data.Text.Encoding as TE
+
+import Database.Persist
+import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate,
sqlType)
+import Database.Persist.Quasi
-- | This special-cases "type_" and strips out its underscore. When
-- used for JSON serialization and deserialization, it works around
@@ -111,17 +103,19 @@
persistLowerCase = persistWith lowerCaseSettings
-- | Same as 'persistWith', but uses an external file instead of a
--- quasiquotation.
+-- quasiquotation. The recommended file extension is @.persistentmodels@.
persistFileWith :: PersistSettings -> FilePath -> Q Exp
persistFileWith ps fp = persistManyFileWith ps [fp]
-- | Same as 'persistFileWith', but uses several external files instead of
--- one. Splitting your Persistent definitions into multiple modules can
+-- one. Splitting your Persistent definitions into multiple modules can
-- potentially dramatically speed up compile times.
--
+-- The recommended file extension is @.persistentmodels@.
+--
-- ==== __Examples__
--
--- Split your Persistent definitions into multiple files (@models1@,
@models2@),
+-- Split your Persistent definitions into multiple files (@models1@,
@models2@),
-- then create a new module for each new file and run 'mkPersist' there:
--
-- @
@@ -143,13 +137,13 @@
-- -- Migrate.hs
-- 'share'
-- ['mkMigrate' "migrateAll"]
--- $('persistManyFileWith' 'lowerCaseSettings' ["models1","models2"])
+-- $('persistManyFileWith' 'lowerCaseSettings'
["models1.persistentmodels","models2.persistentmodels"])
-- @
--
-- Tip: To get the same import behavior as if you were declaring all your
models in
-- one file, import your new files @as Name@ into another file, then export
@module Name@.
--
--- This approach may be used in the future to reduce memory usage during
compilation,
+-- This approach may be used in the future to reduce memory usage during
compilation,
-- but so far we've only seen mild reductions.
--
-- See <https://github.com/yesodweb/persistent/issues/778 persistent#778> and
@@ -158,9 +152,7 @@
-- @since 2.5.4
persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp
persistManyFileWith ps fps = do
-#ifdef GHC_7_4
mapM_ qAddDependentFile fps
-#endif
ss <- mapM getS fps
let s = T.intercalate "\n" ss -- be tolerant of the user forgetting to put
a line-break at EOF.
parseReferences ps s
@@ -254,7 +246,7 @@
data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp
instance Lift FieldSqlTypeExp where
lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) =
- [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs
fieldStrict fieldReference|]
+ [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs
fieldStrict fieldReference fieldComments|]
instance Lift EntityDefSqlTypeExp where
lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
@@ -365,7 +357,8 @@
x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents
y <- fmap mconcat $ mapM (mkEntity entMap mps) ents
z <- fmap mconcat $ mapM (mkJSON mps) ents
- return $ mconcat [x, y, z]
+ uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents
+ return $ mconcat [x, y, z, uniqueKeyInstances]
where
ents = map fixEntityDef ents'
entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) ents
@@ -436,13 +429,6 @@
sqlSettings :: MkPersistSettings
sqlSettings = mkPersistSettings $ ConT ''SqlBackend
--- | Same as 'sqlSettings'.
---
--- @since 1.1.1
-sqlOnlySettings :: MkPersistSettings
-sqlOnlySettings = sqlSettings
-{-# DEPRECATED sqlOnlySettings "use sqlSettings" #-}
-
recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text
recNameNoUnderscore mps dt f
| mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft
@@ -477,13 +463,11 @@
Nothing
constrs
<$> fmap (pure . DerivClause Nothing) (mapM conT names)
-#elif MIN_VERSION_template_haskell(2,11,0)
+#else
DataD [] nameFinal paramsFinal
Nothing
constrs
<$> mapM conT names
-#else
- return $ DataD [] nameFinal paramsFinal constrs names
#endif
where
mkCol x fd@FieldDef {..} =
@@ -520,19 +504,15 @@
uniqueTypeDec mps t =
DataInstD [] ''Unique
[genericDataType mps (entityHaskell t) backendT]
-#if MIN_VERSION_template_haskell(2,11,0)
Nothing
-#endif
(map (mkUnique mps t) $ entityUniques t)
(derivClause $ entityUniques t)
where
derivClause [] = []
#if MIN_VERSION_template_haskell(2,12,0)
derivClause _ = [DerivClause Nothing [ConT ''Show]]
-#elif MIN_VERSION_template_haskell(2,11,0)
- derivClause _ = [ConT ''Show]
#else
- derivClause _ = [''Show]
+ derivClause _ = [ConT ''Show]
#endif
mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
@@ -790,15 +770,11 @@
let kd = if useNewtype
then NewtypeInstD [] k [recordType] Nothing dec [DerivClause
Nothing cxti]
else DataInstD [] k [recordType] Nothing [dec] [DerivClause
Nothing cxti]
-#elif MIN_VERSION_template_haskell(2,11,0)
+#else
cxti <- mapM conT i
let kd = if useNewtype
then NewtypeInstD [] k [recordType] Nothing dec cxti
else DataInstD [] k [recordType] Nothing [dec] cxti
-#else
- let kd = if useNewtype
- then NewtypeInstD [] k [recordType] dec i
- else DataInstD [] k [recordType] [dec] i
#endif
return (kd, instDecs)
where
@@ -808,7 +784,7 @@
k = ''Key
recordType = genericDataType mps (entityHaskell t) backendT
pfInstD = -- FIXME: generate a PersistMap instead of PersistList
- [d|instance PersistField (Key $(A.pure recordType)) where
+ [d|instance PersistField (Key $(pure recordType)) where
toPersistValue = PersistList . keyToValues
fromPersistValue (PersistList l) = keyFromValues l
fromPersistValue got = error $ "fromPersistValue: expected
PersistList, got: " `mappend` show got
@@ -946,7 +922,7 @@
mkKeyToValues mps t = do
(p, e) <- case entityPrimary t of
Nothing ->
- ([],) A.<$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|]
+ ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|]
Just pdef ->
return $ toValuesPrimary pdef
return $ FunD 'keyToValues $ return $ normalClause p e
@@ -996,7 +972,7 @@
(fpv1:mkPersistValues) <- mapM mkPersistValue fields
app1E <- [|(<$>)|]
let conApp = infixFromPersistValue app1E fpv1 conE x1
- applyE <- [|(A.<*>)|]
+ applyE <- [|(<*>)|]
let applyFromPersistValue = infixFromPersistValue applyE
return $ normalClause
@@ -1080,22 +1056,15 @@
[ genDataType
, VarT $ mkName "typ"
]
-#if MIN_VERSION_template_haskell(2,11,0)
Nothing
-#endif
(map fst fields)
[]
, FunD 'persistFieldDef (map snd fields)
, TySynInstD
''PersistEntityBackend
-#if MIN_VERSION_template_haskell(2,9,0)
(TySynEqn
[genDataType]
(backendDataType mps))
-#else
- [genDataType]
- (backendDataType mps)
-#endif
, FunD 'persistIdField [normalClause [] (ConE $ keyIdName t)]
, FunD 'fieldLens lensClauses
]
@@ -1104,6 +1073,84 @@
genDataType = genericDataType mps entName backendT
entName = entityHaskell t
+mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
+mkUniqueKeyInstances mps t = do
+ -- FIXME: isExtEnabled breaks the benchmark
+ undecidableInstancesEnabled <- isExtEnabled UndecidableInstances
+ unless undecidableInstancesEnabled . fail
+ $ "Generating Persistent entities now requires the
'UndecidableInstances' "
+ `mappend` "language extension. Please enable it in your file by
copy/pasting "
+ `mappend` "this line into the top of your file: \n\n"
+ `mappend` "{-# LANGUAGE UndecidableInstances #-}"
+ case entityUniques t of
+ [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne
+ [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey
+ (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey
+ where
+ requireUniquesPName = mkName "requireUniquesP"
+ onlyUniquePName = mkName "onlyUniqueP"
+ typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx
+ typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx
+
+ withPersistStoreWriteCxt =
+ if mpsGeneric mps
+ then do
+ write <- [t|PersistStoreWrite $(pure (VarT $ mkName
"backend")) |]
+ pure [write]
+ else do
+ pure []
+
+ typeErrorNoneCtx = do
+ tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|]
+ (tyErr :) <$> withPersistStoreWriteCxt
+
+ typeErrorMultipleCtx = do
+ tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|]
+ (tyErr :) <$> withPersistStoreWriteCxt
+
+ mkOnlyUniqueError :: Q Cxt -> Q [Dec]
+ mkOnlyUniqueError mkCtx = do
+ ctx <- mkCtx
+ let impl = mkImpossible onlyUniquePName
+ pure [instanceD ctx onlyOneUniqueKeyClass impl]
+
+ mkImpossible name =
+ [ FunD name
+ [ Clause
+ [ WildP ]
+ (NormalB
+ (VarE (mkName "error") `AppE` LitE (StringL "impossible"))
+ )
+ []
+ ]
+ ]
+
+ typeErrorAtLeastOne :: Q [Dec]
+ typeErrorAtLeastOne = do
+ let impl = mkImpossible requireUniquesPName
+ cxt <- typeErrorMultipleCtx
+ pure [instanceD cxt atLeastOneUniqueKeyClass impl]
+
+ singleUniqueKey :: Q [Dec]
+ singleUniqueKey = do
+ expr <- [e|\p -> head (persistUniqueKeys p)|]
+ let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]]
+ cxt <- withPersistStoreWriteCxt
+ pure [instanceD cxt onlyOneUniqueKeyClass impl]
+
+ atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType
+ onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType
+
+ atLeastOneKey :: Q [Dec]
+ atLeastOneKey = do
+ expr <- [e|\p -> NEL.fromList (persistUniqueKeys p)|]
+ let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]]
+ cxt <- withPersistStoreWriteCxt
+ pure [instanceD cxt atLeastOneUniqueKeyClass impl]
+
+ genDataType = genericDataType mps (entityHaskell t) backendT
+
+
entityText :: EntityDef -> Text
entityText = unHaskellName . entityHaskell
@@ -1282,13 +1329,13 @@
just <- [|Just|]
filt <- [|Filter|]
eq <- [|Eq|]
- left <- [|Left|]
+ value <- [|FilterValue|]
let mkStmt :: Dep -> Stmt
mkStmt dep = NoBindS
$ dcw `AppE`
ListE
[ filt `AppE` ConE filtName
- `AppE` (left `AppE` val (depSourceNull dep))
+ `AppE` (value `AppE` val (depSourceNull dep))
`AppE` eq
]
where
@@ -1473,11 +1520,12 @@
entityDerives
entityExtra
entitySum
+ entityComments
|]
liftAndFixKey :: EntityMap -> FieldDef -> Q Exp
-liftAndFixKey entMap (FieldDef a b c sqlTyp e f fieldRef) =
- [|FieldDef a b c $(sqlTyp') e f fieldRef'|]
+liftAndFixKey entMap (FieldDef a b c sqlTyp e f fieldRef mcomments) =
+ [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|]
where
(fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $
case fieldRef of
@@ -1502,9 +1550,10 @@
entityDerives
entityExtra
entitySum
+ entityComments
|]
instance Lift FieldDef where
- lift (FieldDef a b c d e f g) = [|FieldDef a b c d e f g|]
+ lift (FieldDef a b c d e f g h) = [|FieldDef a b c d e f g h|]
instance Lift UniqueDef where
lift (UniqueDef a b c d) = [|UniqueDef a b c d|]
instance Lift CompositeDef where
@@ -1522,22 +1571,15 @@
instance (Lift' k, Lift' v) => Lift' (M.Map k v) where
lift' m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|]
+-- overlapping instances is for automatic lifting
+-- while avoiding an orphan of Lift for Text
+
-- auto-lifting, means instances are overlapping
-#if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPPABLE #-} Lift' a => Lift a where
-#else
-instance Lift' a => Lift a where
-#endif
lift = lift'
-packPTH :: String -> Text
-packPTH = pack
-#if !MIN_VERSION_text(0, 11, 2)
-{-# NOINLINE packPTH #-}
-#endif
-
liftT :: Text -> Q Exp
-liftT t = [|packPTH $(lift (unpack t))|]
+liftT t = [|pack $(lift (unpack t))|]
liftPair :: (Lift' k, Lift' v) => (k, v) -> Q Exp
liftPair (k, v) = [|($(lift' k), $(lift' v))|]
@@ -1688,12 +1730,10 @@
Just entityJSON -> do
entityJSONIs <- if mpsGeneric mps
then [d|
-#if MIN_VERSION_base(4, 6, 0)
instance PersistStore $(pure backendT) => ToJSON (Entity
$(pure typ)) where
toJSON = $(varE (entityToJSON entityJSON))
instance PersistStore $(pure backendT) => FromJSON (Entity
$(pure typ)) where
parseJSON = $(varE (entityFromJSON entityJSON))
-#endif
|]
else [d|
instance ToJSON (Entity $(pure typ)) where
@@ -1704,39 +1744,19 @@
return $ toJSONI : fromJSONI : entityJSONIs
mkClassP :: Name -> [Type] -> Pred
-#if MIN_VERSION_template_haskell(2,10,0)
mkClassP cla tys = foldl AppT (ConT cla) tys
-#else
-mkClassP = ClassP
-#endif
mkEqualP :: Type -> Type -> Pred
-#if MIN_VERSION_template_haskell(2,10,0)
mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright]
-#else
-mkEqualP = EqualP
-#endif
-#if MIN_VERSION_template_haskell(2,11,0)
notStrict :: Bang
notStrict = Bang NoSourceUnpackedness NoSourceStrictness
isStrict :: Bang
isStrict = Bang NoSourceUnpackedness SourceStrict
-#else
-notStrict :: Strict
-notStrict = NotStrict
-
-isStrict :: Strict
-isStrict = IsStrict
-#endif
instanceD :: Cxt -> Type -> [Dec] -> Dec
-#if MIN_VERSION_template_haskell(2,11,0)
instanceD = InstanceD Nothing
-#else
-instanceD = InstanceD
-#endif
-- entityUpdates :: EntityDef -> [(HaskellName, FieldType, IsNullable,
PersistUpdate)]
-- entityUpdates =
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.6.0/bench/Main.hs
new/persistent-template-2.7.0/bench/Main.hs
--- old/persistent-template-2.6.0/bench/Main.hs 1970-01-01 01:00:00.000000000
+0100
+++ new/persistent-template-2.7.0/bench/Main.hs 2019-04-15 04:27:15.000000000
+0200
@@ -0,0 +1,191 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+module Main (main) where
+
+import Control.DeepSeq
+import Control.DeepSeq.Generics
+import Criterion.Main
+import Data.Text (Text)
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import Database.Persist.Quasi
+import Database.Persist.TH
+import Models
+
+main :: IO ()
+main = defaultMain
+ [ bgroup "mkPersist"
+ [ bench "From File" $ nfIO $ mkPersist' $(persistFileWith
lowerCaseSettings "bench/models-slowly")
+ --, bgroup "Non-Null Fields"
+ -- , bgroup "Increasing model count"
+ -- [ bench "1x10" $ nfIO $ mkPersist' $( parseReferencesQ
(mkModels 10 10))
+ -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkModels 10 10))
+ -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkModels 100 10))
+ -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkModels 1000 10))
+ -- ]
+ -- , bgroup "Increasing field count"
+ -- [ bench "10x1" $ nfIO $ mkPersist' $(parseReferencesQ
(mkModels 10 1))
+ -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkModels 10 10))
+ -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ
(mkModels 10 100))
+ -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ
(mkModels 10 1000))
+ -- ]
+ -- ]
+ --, bgroup "Nullable"
+ -- [ bgroup "Increasing model count"
+ -- [ bench "20x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 20 10))
+ -- , bench "40x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 40 10))
+ -- , bench "60x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 60 10))
+ -- , bench "80x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 80 10))
+ -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 100 10))
+ -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 1000 10))
+ -- ]
+ -- , bgroup "Increasing field count"
+ -- [ bench "10x20" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 10 20))
+ -- , bench "10x40" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 10 40))
+ -- , bench "10x60" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 10 60))
+ -- , bench "10x80" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 10 80))
+ -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 10 100))
+ -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ
(mkNullableModels 10 1000))
+ -- ]
+ -- ]
+ ]
+ ]
+
+-- Orphan instances for NFData Template Haskell types
+instance NFData Overlap where
+ rnf = genericRnf
+
+instance NFData AnnTarget where
+ rnf = genericRnf
+instance NFData RuleBndr where
+ rnf = genericRnf
+
+instance NFData Role where
+ rnf = genericRnf
+
+instance NFData Phases where
+ rnf = genericRnf
+
+instance NFData InjectivityAnn where
+ rnf = genericRnf
+
+instance NFData FamilyResultSig where
+ rnf = genericRnf
+
+instance NFData RuleMatch where
+ rnf = genericRnf
+
+instance NFData TypeFamilyHead where
+ rnf = genericRnf
+
+instance NFData TySynEqn where
+ rnf = genericRnf
+
+instance NFData Inline where
+ rnf = genericRnf
+
+instance NFData Pragma where
+ rnf = genericRnf
+
+instance NFData FixityDirection where
+ rnf = genericRnf
+
+instance NFData Safety where
+ rnf = genericRnf
+
+instance NFData Fixity where
+ rnf = genericRnf
+
+instance NFData Callconv where
+ rnf = genericRnf
+
+instance NFData Foreign where
+ rnf = genericRnf
+
+instance NFData SourceStrictness where
+ rnf = genericRnf
+
+instance NFData SourceUnpackedness where
+ rnf = genericRnf
+
+instance NFData FunDep where
+ rnf = genericRnf
+
+instance NFData Bang where
+ rnf = genericRnf
+
+#if MIN_VERSION_template_haskell(2,12,0)
+instance NFData PatSynDir where
+ rnf = genericRnf
+
+instance NFData PatSynArgs where
+ rnf = genericRnf
+
+instance NFData DerivStrategy where
+ rnf = genericRnf
+
+instance NFData DerivClause where
+ rnf = genericRnf
+#endif
+
+instance NFData Con where
+ rnf = genericRnf
+
+instance NFData Range where
+ rnf = genericRnf
+
+instance NFData Clause where
+ rnf = genericRnf
+
+instance NFData PkgName where
+ rnf = genericRnf
+
+instance NFData Dec where
+ rnf = genericRnf
+
+instance NFData Stmt where
+ rnf = genericRnf
+
+instance NFData TyLit where
+ rnf = genericRnf
+
+instance NFData NameSpace where
+ rnf = genericRnf
+
+instance NFData Body where
+ rnf = genericRnf
+
+instance NFData Guard where
+ rnf = genericRnf
+
+instance NFData Match where
+ rnf = genericRnf
+
+instance NFData ModName where
+ rnf = genericRnf
+
+instance NFData Pat where
+ rnf = genericRnf
+
+instance NFData TyVarBndr where
+ rnf = genericRnf
+
+instance NFData NameFlavour where
+ rnf = genericRnf
+
+instance NFData Type where
+ rnf = genericRnf
+
+instance NFData Exp where
+ rnf = genericRnf
+
+instance NFData Lit where
+ rnf = genericRnf
+
+instance NFData OccName where
+ rnf = genericRnf
+
+instance NFData Name where
+ rnf = genericRnf
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.6.0/bench/Models.hs
new/persistent-template-2.7.0/bench/Models.hs
--- old/persistent-template-2.6.0/bench/Models.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/persistent-template-2.7.0/bench/Models.hs 2019-04-15
04:27:15.000000000 +0200
@@ -0,0 +1,59 @@
+module Models where
+
+import Data.Monoid
+import Language.Haskell.TH
+import qualified Data.Text as Text
+
+import Database.Persist.Quasi
+import Database.Persist.TH
+import Database.Persist.Sql
+
+mkPersist' :: [EntityDef] -> IO [Dec]
+mkPersist' = runQ . mkPersist sqlSettings
+
+parseReferences' :: String -> IO Exp
+parseReferences' = runQ . parseReferencesQ
+
+parseReferencesQ :: String -> Q Exp
+parseReferencesQ = parseReferences lowerCaseSettings . Text.pack
+
+-- | # of models, # of fields
+mkModels :: Int -> Int -> String
+mkModels = mkModelsWithFieldModifier id
+
+mkNullableModels :: Int -> Int -> String
+mkNullableModels = mkModelsWithFieldModifier maybeFields
+
+mkModelsWithFieldModifier :: (String -> String) -> Int -> Int -> String
+mkModelsWithFieldModifier k i f =
+ unlines . fmap unlines . take i . map mkModel . zip [0..] . cycle $
+ [ "Model"
+ , "Foobar"
+ , "User"
+ , "King"
+ , "Queen"
+ , "Dog"
+ , "Cat"
+ ]
+ where
+ mkModel :: (Int, String) -> [String]
+ mkModel (i', m) =
+ (m <> show i') : indent 4 (map k (mkFields f))
+
+indent :: Int -> [String] -> [String]
+indent i = map (replicate i ' ' ++)
+
+mkFields :: Int -> [String]
+mkFields i = take i $ map mkField $ zip [0..] $ cycle
+ [ "Bool"
+ , "Int"
+ , "String"
+ , "Double"
+ , "Text"
+ ]
+ where
+ mkField :: (Int, String) -> String
+ mkField (i', typ) = "field" <> show i' <> "\t\t" <> typ
+
+maybeFields :: String -> String
+maybeFields = (++ " Maybe")
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.6.0/persistent-template.cabal
new/persistent-template-2.7.0/persistent-template.cabal
--- old/persistent-template-2.6.0/persistent-template.cabal 2018-12-30
02:20:10.000000000 +0100
+++ new/persistent-template-2.7.0/persistent-template.cabal 2019-04-15
04:27:15.000000000 +0200
@@ -1,5 +1,5 @@
name: persistent-template
-version: 2.6.0
+version: 2.7.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <[email protected]>
@@ -8,49 +8,64 @@
description: Hackage documentation generation is not reliable. For up to
date documentation, please see:
<http://www.stackage.org/package/persistent-template>.
category: Database, Yesod
stability: Stable
-cabal-version: >= 1.8
+cabal-version: >= 1.10
build-type: Simple
homepage: http://www.yesodweb.com/book/persistent
bug-reports: https://github.com/yesodweb/persistent/issues
extra-source-files: test/main.hs ChangeLog.md README.md
library
- build-depends: base >= 4.6 && < 5
- , template-haskell
- , persistent >= 2.5 && < 3
- , monad-control >= 0.2 && < 1.1
- , bytestring >= 0.9
- , text >= 0.5
- , transformers >= 0.2 && < 0.6
+ build-depends: base >= 4.9 && < 5
+ , persistent >= 2.10 && < 3
+ , aeson >= 1.0 && < 1.5
+ , bytestring >= 0.10
, containers
- , aeson >= 0.7 && < 1.5
- , aeson-compat >= 0.3.2.0 && < 0.4
+ , http-api-data >= 0.3.7
+ , monad-control >= 1.0 && < 1.1
, monad-logger
- , unordered-containers
- , tagged
, path-pieces
- , http-api-data >= 0.2
- , ghc-prim
+ , template-haskell >= 2.11
+ , text >= 1.2
+ , transformers >= 0.5 && < 0.6
+ , unordered-containers
exposed-modules: Database.Persist.TH
ghc-options: -Wall
- if impl(ghc >= 7.4)
- cpp-options: -DGHC_7_4
+ default-language: Haskell2010
test-suite test
- type: exitcode-stdio-1.0
- main-is: main.hs
- hs-source-dirs: test
+ type: exitcode-stdio-1.0
+ main-is: main.hs
+ hs-source-dirs: test
+ other-modules: TemplateTestImports
+ ghc-options: -Wall
- build-depends: base >= 4.6 && < 5
+ build-depends: base >= 4.9 && < 5
+ , persistent
, persistent-template
, aeson
- , hspec >= 1.3
- , text
- , persistent
, bytestring
+ , hspec >= 2.4
, QuickCheck
- , transformers
+ , text
+ default-language: Haskell2010
source-repository head
type: git
location: git://github.com/yesodweb/persistent.git
+
+benchmark persistent-th-bench
+ ghc-options: -O2
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs: bench
+ build-depends: base
+ , persistent
+ , persistent-template
+ , criterion
+ , deepseq
+ , deepseq-generics
+ , file-embed
+ , text
+ , template-haskell
+ other-modules: Models
+ default-language: Haskell2010
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/persistent-template-2.6.0/test/TemplateTestImports.hs
new/persistent-template-2.7.0/test/TemplateTestImports.hs
--- old/persistent-template-2.6.0/test/TemplateTestImports.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/persistent-template-2.7.0/test/TemplateTestImports.hs 2019-04-15
04:27:15.000000000 +0200
@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TemplateTestImports where
+
+import Data.Aeson.TH
+import Test.QuickCheck
+
+import Database.Persist.TH
+
+data Foo = Bar | Baz
+ deriving (Show, Eq)
+
+deriveJSON defaultOptions ''Foo
+
+derivePersistFieldJSON "Foo"
+
+instance Arbitrary Foo where
+ arbitrary = elements [Bar, Baz]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.6.0/test/main.hs
new/persistent-template-2.7.0/test/main.hs
--- old/persistent-template-2.6.0/test/main.hs 2018-07-15 06:56:03.000000000
+0200
+++ new/persistent-template-2.7.0/test/main.hs 2019-04-15 04:27:15.000000000
+0200
@@ -1,30 +1,38 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies,
GADTs #-}
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
module Main
(
-- avoid unused ident warnings
module Main
) where
+
+import Control.Applicative (Const (..))
+import Data.Aeson
+import Data.ByteString.Lazy.Char8 ()
+import Data.Functor.Identity (Identity (..))
+import Data.Text (Text, pack)
import Test.Hspec
import Test.Hspec.QuickCheck
-import Data.ByteString.Lazy.Char8 ()
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen (Gen)
-import Control.Applicative as A ((<$>), (<*>), Const (..))
-import Data.Functor.Identity (Identity (..))
import Database.Persist
import Database.Persist.TH
-import Data.Text (Text, pack)
-import Data.Aeson
+import TemplateTestImports
+
share [mkPersist sqlSettings { mpsGeneric = False }, mkDeleteCascade
sqlSettings { mpsGeneric = False }] [persistUpperCase|
Person json
name Text
age Int Maybe
+ foo Foo
address Address
deriving Show Eq
Address json
@@ -51,10 +59,10 @@
|]
arbitraryT :: Gen Text
-arbitraryT = pack A.<$> arbitrary
+arbitraryT = pack <$> arbitrary
instance Arbitrary Person where
- arbitrary = Person <$> arbitraryT A.<*> arbitrary <*> arbitrary
+ arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary Address where
arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary
@@ -64,15 +72,15 @@
prop "to/from is idempotent" $ \person ->
decode (encode person) == Just (person :: Person)
it "decode" $
- decode
"{\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}"
`shouldBe` Just
- (Person "Michael" (Just 27) $ Address "Narkis" "Maalot"
Nothing)
+ decode
"{\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}"
`shouldBe` Just
+ (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot"
Nothing)
describe "JSON serialization for Entity" $ do
let key = PersonKey 0
prop "to/from is idempotent" $ \person ->
decode (encode (Entity key person)) == Just (Entity key (person ::
Person))
it "decode" $
- decode "{\"id\": 0,
\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}"
`shouldBe` Just
- (Entity key (Person "Michael" (Just 27) $ Address "Narkis"
"Maalot" Nothing))
+ decode "{\"id\": 0,
\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}"
`shouldBe` Just
+ (Entity key (Person "Michael" (Just 27) Bar $ Address "Narkis"
"Maalot" Nothing))
it "lens operations" $ do
let street1 = "street1"
city1 = "city1"
