persistent-template 2.7.4 → 2.8.0
raw patch · 5 files changed
+98/−81 lines, 5 filesdep ~basedep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
Files
- ChangeLog.md +8/−0
- Database/Persist/TH.hs +64/−78
- README.md +14/−0
- persistent-template.cabal +3/−3
- test/main.hs +9/−0
ChangeLog.md view
@@ -1,5 +1,13 @@ ## Unreleased changes +## 2.8.0++* Reduces the amount of code generated by Template Haskell. The amount of code generated for a certain function was O(N^2) with respect to the number of fields on a given Entity. This change shows dramatic improvements in benchmarks for compiling Persistent models. [#]()+* Drops support for GHC 8.0, so that `DerivingStrategies` can be used by `persistent-template`+* `persistent-template` now requires `DerivingStrategies`, `GeneralizedNewtypeDeriving`, and `StandaloneDeriving` to be enabled in the file where Persistent entities are created+* Fixes a long-standing issue where persistent-template would fail when `DeriveAnyClass` was enabled (See #578)+* [#1002](https://github.com/yesodweb/persistent/pull/1002)+ ## 2.7.4 * Remove an overlapping instance for `Lift a`. [#998](https://github.com/yesodweb/persistent/pull/998)
Database/Persist/TH.hs view
@@ -7,6 +7,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} -- | This module provides the tools for defining your database schema and using@@ -46,9 +49,12 @@ , OnlyOneUniqueKey(..) ) where +-- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code+-- It's highly recommended to check the diff between master and your PR's generated code.+ import Prelude hiding ((++), take, concat, splitAt, exp) -import Control.Monad (forM, unless, (<=<), mzero)+import Control.Monad (forM, (<=<), mzero, filterM) import Data.Aeson ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object , Value (Object), (.:), (.:?)@@ -59,6 +65,7 @@ import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.List (foldl')+import qualified Data.List as List import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe)@@ -76,7 +83,6 @@ import Language.Haskell.TH.Lib (conT, varE) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax-import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident)) import Web.PathPieces (PathPiece(..)) import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) @@ -496,17 +502,10 @@ dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec dataTypeDec mps t = do let names = map (mkName . unpack) $ entityDerives t-#if MIN_VERSION_template_haskell(2,12,0) DataD [] nameFinal paramsFinal Nothing constrs <$> fmap (pure . DerivClause Nothing) (mapM conT names)-#else- DataD [] nameFinal paramsFinal- Nothing- constrs- <$> mapM conT names-#endif where mkCol x fd@FieldDef {..} = (mkName $ unpack $ recName mps x fieldHaskell,@@ -555,11 +554,7 @@ #endif where derivClause [] = []-#if MIN_VERSION_template_haskell(2,12,0) derivClause _ = [DerivClause Nothing [ConT ''Show]]-#else- derivClause _ = [ConT ''Show]-#endif mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) =@@ -809,21 +804,18 @@ bi <- backendKeyI return (bi, allInstances) + requirePersistentExtensions+ #if MIN_VERSION_template_haskell(2,15,0) cxti <- mapM conT i let kd = if useNewtype- then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec [DerivClause Nothing cxti]- else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] [DerivClause Nothing cxti]-#elif MIN_VERSION_template_haskell(2,12,0)- cxti <- mapM conT i- let kd = if useNewtype- then NewtypeInstD [] k [recordType] Nothing dec [DerivClause Nothing cxti]- else DataInstD [] k [recordType] Nothing [dec] [DerivClause Nothing cxti]+ then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec [DerivClause (Just NewtypeStrategy) cxti]+ else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] [DerivClause (Just StockStrategy) cxti] #else cxti <- mapM conT i let kd = if useNewtype- then NewtypeInstD [] k [recordType] Nothing dec cxti- else DataInstD [] k [recordType] Nothing [dec] cxti+ then NewtypeInstD [] k [recordType] Nothing dec [DerivClause (Just NewtypeStrategy) cxti]+ else DataInstD [] k [recordType] Nothing [dec] [DerivClause (Just StockStrategy) cxti] #endif return (kd, instDecs) where@@ -843,10 +835,6 @@ instance FromJSON (Key $(pure recordType)) |] - keyStringL = StringL . keyString- -- ghc 7.6 cannot parse the left arrow Ident $() <- lexP- keyPattern = BindS (ConP 'Ident [LitP $ keyStringL t])- backendKeyGenericI = [d| instance PersistStore $(pure backendT) => ToBackendKey $(pure backendT) $(pure recordType) where@@ -859,43 +847,22 @@ fromBackendKey = $(return keyConE) |] - -- truly unfortunate that TH doesn't support standalone deriving- -- https://ghc.haskell.org/trac/ghc/ticket/8100 genericNewtypeInstances = do- instances <- [|lexP|] >>= \lexPE -> [| step readPrec >>= return . ($(pure keyConE) )|] >>= \readE -> do+ requirePersistentExtensions++ instances <- do alwaysInstances <-- [d|instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) where- showsPrec i x = showParen (i > app_prec) $- (showString $ $(pure $ LitE $ keyStringL t) `mappend` " ") .- showsPrec i ($(return unKeyE) x)- where app_prec = (10::Int)- instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) where- readPrec = parens $ (prec app_prec $ $(pure $ DoE [keyPattern lexPE, NoBindS readE]))- where app_prec = (10::Int)- instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) where- x == y =- ($(return unKeyE) x) ==- ($(return unKeyE) y)- instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) where- compare x y = compare- ($(return unKeyE) x)- ($(return unKeyE) y)- instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType)) where- toUrlPiece = toUrlPiece . $(return unKeyE)- instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType)) where- parseUrlPiece = fmap $(return keyConE) . parseUrlPiece- instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) where- toPathPiece = toPathPiece . $(return unKeyE)- fromPathPiece = fmap $(return keyConE) . fromPathPiece- instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) where- toPersistValue = toPersistValue . $(return unKeyE)- fromPersistValue = fmap $(return keyConE) . fromPersistValue- instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) where- sqlType = sqlType . fmap $(return unKeyE)- instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) where- toJSON = toJSON . $(return unKeyE)- instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) where- parseJSON = fmap $(return keyConE) . parseJSON+ [d|deriving newtype instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType))+ deriving newtype instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType))+ deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType))+ deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType))+ deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType))+ deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType))+ deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType))+ deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType))+ deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType))+ deriving newtype instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType))+ deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) |] if customKeyType then return alwaysInstances@@ -1009,6 +976,7 @@ suc <- patternSuccess return [ suc, normalClause [VarP x] patternMatchFailure ] where+ tableName = unDBName (entityDB t) patternSuccess = case fields of [] -> do@@ -1031,23 +999,18 @@ UInfixE exp applyE (fpv `AppE` VarE name) mkPersistValue field =- [|mapLeft (fieldError t field) . fromPersistValue|]+ let fieldName = (unHaskellName (fieldHaskell field))+ in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|] -fieldError :: EntityDef -> FieldDef -> Text -> Text-fieldError entity field err = mconcat+fieldError :: Text -> Text -> Text -> Text+fieldError tableName fieldName err = mconcat [ "Couldn't parse field `" , fieldName , "` from table `" , tableName , "`. " , err- ]- where- fieldName =- unHaskellName (fieldHaskell field)-- tableName =- unDBName (entityDB entity)+ ] mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec] mkEntity entityMap mps t = do@@ -1141,13 +1104,7 @@ 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 #-}"+ requirePersistentExtensions case entityUniques t of [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey@@ -1863,3 +1820,32 @@ -- let x = mkName "x" -- in normalClause [ConP (mkName constr) [VarP x]] -- (VarE 'toPersistValue `AppE` VarE x)++-- | Check that all of Persistent's required extensions are enabled, or else fail compilation+--+-- This function should be called before any code that depends on one of the required extensions being enabled.+requirePersistentExtensions :: Q ()+requirePersistentExtensions = do+ -- isExtEnabled breaks the persistent-template benchmark with the following error:+ -- Template Haskell error: Can't do `isExtEnabled' in the IO monad+ -- You can workaround this by replacing isExtEnabled with (pure . const True)+ unenabledExtensions <- filterM (fmap not . isExtEnabled) requiredExtensions++ case unenabledExtensions of+ [] -> pure ()+ [extension] -> fail $ mconcat + [ "Generating Persistent entities now requires the "+ , show extension+ , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n"+ , extensionToPragma extension+ ]+ extensions -> fail $ mconcat + [ "Generating Persistent entities now requires the following language extensions:\n\n"+ , List.intercalate "\n" (map show extensions)+ , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"+ , List.intercalate "\n" (map extensionToPragma extensions)+ ]+ + where+ requiredExtensions = [DerivingStrategies, GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances]+ extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}"
README.md view
@@ -9,3 +9,17 @@ persistent-template uses `EntityDef`s that it gets from the quasi-quoter. The quasi-quoter is in persistent Quasi.hs Similarly mant of the types come from the persistent library++### Development tips++To get a better idea of what code you're generating, you can output the content of Template Haskell expressions to a file:++```+stack test persistent-template --ghc-options='-ddump-splices -ddump-file'+```++The output will be in the `.stack-work` directory. The exact path will depend on your specific setup, but if you search for files ending in `.dump-splices` you'll find the output (`find .stack-work -type f -name '*.dump-splices'`)++If you make changes to the generated code, it is highly recommended to compare the output with your changes to output from `master` (even better if this diff is included in your PR!). Seemingly small changes can have dramatic changes on the generated code. ++For example, embedding an `EntityDef` in a function that was called for every field of that `Entity` made the number of generated lines O(N^2) for that function—very bad!
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.7.4+version: 2.8.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -15,7 +15,7 @@ extra-source-files: test/main.hs ChangeLog.md README.md library- build-depends: base >= 4.9 && < 5+ build-depends: base >= 4.10 && < 5 , persistent >= 2.10 && < 3 , aeson >= 1.0 && < 1.5 , bytestring >= 0.10@@ -40,7 +40,7 @@ other-modules: TemplateTestImports ghc-options: -Wall - build-depends: base >= 4.9 && < 5+ build-depends: base >= 4.10 && < 5 , persistent , persistent-template , aeson
test/main.hs view
@@ -7,6 +7,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++-- DeriveAnyClass is not actually used by persistent-template+-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving+-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.+-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.+-- See https://github.com/yesodweb/persistent/issues/578+{-# LANGUAGE DeriveAnyClass #-} module Main ( -- avoid unused ident warnings