diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -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 <> " #-}" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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! diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -1,5 +1,5 @@ name: persistent-template -version: 2.7.4 +version: 2.8.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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