persistent-template 2.6.0 → 2.7.0
raw patch · 7 files changed
+471/−156 lines, 7 filesdep +criteriondep +deepseqdep +deepseq-genericsdep −aeson-compatdep −ghc-primdep −taggeddep ~aesondep ~basedep ~bytestringnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: criterion, deepseq, deepseq-generics, file-embed
Dependencies removed: aeson-compat, ghc-prim, tagged
Dependency ranges changed: aeson, base, bytestring, hspec, http-api-data, monad-control, persistent, template-haskell, text, transformers
API changes (from Hackage documentation)
- Database.Persist.TH: packPTH :: String -> Text
- Database.Persist.TH: sqlOnlySettings :: MkPersistSettings
+ Database.Persist.TH: class PersistEntity record => AtLeastOneUniqueKey record
+ Database.Persist.TH: class PersistEntity record => OnlyOneUniqueKey record
+ Database.Persist.TH: onlyUniqueP :: OnlyOneUniqueKey record => record -> Unique record
+ Database.Persist.TH: requireUniquesP :: AtLeastOneUniqueKey record => record -> NonEmpty (Unique record)
Files
- ChangeLog.md +5/−0
- Database/Persist/TH.hs +136/−116
- bench/Main.hs +191/−0
- bench/Models.hs +59/−0
- persistent-template.cabal +40/−25
- test/TemplateTestImports.hs +17/−0
- test/main.hs +23/−15
ChangeLog.md view
@@ -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`
Database/Persist/TH.hs view
@@ -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,49 +37,48 @@ , 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 -- <https://github.com/yesodweb/persistent/issues/412>@@ -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 =
+ bench/Main.hs view
@@ -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
+ bench/Models.hs view
@@ -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")
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.6.0+version: 2.7.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -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
+ test/TemplateTestImports.hs view
@@ -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]
test/main.hs view
@@ -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"