persistent-template 2.8.0 → 2.8.0.1
raw patch · 5 files changed
+46/−35 lines, 5 filesdep ~persistentPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: persistent
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- Database/Persist/TH.hs +37/−30
- README.md +1/−1
- bench/Main.hs +3/−3
- persistent-template.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,9 @@ ## Unreleased changes +## 2.8.0.1++* Small optimization/code cleanup to generated Template Haskell code size, by slimming the implementation of to/fromPersistValue for Entities. [#1014](https://github.com/yesodweb/persistent/pull/1014)+ ## 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. [#]()
Database/Persist/TH.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} -- | This module provides the tools for defining your database schema and using@@ -54,7 +55,7 @@ import Prelude hiding ((++), take, concat, splitAt, exp) -import Control.Monad (forM, (<=<), mzero, filterM)+import Control.Monad (forM, mzero, filterM) import Data.Aeson ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object , Value (Object), (.:), (.:?)@@ -1251,50 +1252,56 @@ maybeTyp may typ | may = ConT ''Maybe `AppT` typ | otherwise = typ --- | produce code similar to the following:+++entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue+entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues+ where+ columnNames = map (unHaskellName . fieldHaskell) (entityFields (entityDef (Just entity)))+ fieldsAsPersistValues = map toPersistValue $ toPersistFields entity++entityFromPersistValueHelper :: (PersistEntity record) + => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code+ -> PersistValue+ -> Either Text record+entityFromPersistValueHelper columnNames pv = do+ (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv++ let columnMap = HM.fromList persistMap+ lookupPersistValueByColumnName :: String -> PersistValue+ lookupPersistValueByColumnName columnName = + fromMaybe PersistNull (HM.lookup (pack columnName) columnMap)+ + fromPersistValues $ map lookupPersistValueByColumnName columnNames++-- | Produce code similar to the following: -- -- @ -- instance PersistEntity e => PersistField e where--- toPersistValue = PersistMap $ zip columNames (map toPersistValue . toPersistFields)--- fromPersistValue (PersistMap o) =--- let columns = HM.fromList o--- in fromPersistValues $ map (\name ->--- case HM.lookup name columns of--- Just v -> v--- Nothing -> PersistNull--- fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x+-- toPersistValue = entityToPersistValueHelper+-- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"] -- sqlType _ = SqlString -- @ persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec]-persistFieldFromEntity mps e = do- ss <- [|SqlString|]- obj <- [|\ent -> PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields ent)|]- fpv <- [|\x -> let columns = HM.fromList x- in fromPersistValues $ map- (\(name) ->- case HM.lookup (pack name) columns of- Just v -> v- Nothing -> PersistNull)- $ columnNames- |]+persistFieldFromEntity mps entDef = do+ sqlStringConstructor' <- [|SqlString|]+ toPersistValueImplementation <- [|entityToPersistValueHelper|]+ fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|] - compose <- [|(<=<)|]- getPersistMap' <- [|getPersistMap|] return [ persistFieldInstanceD (mpsGeneric mps) typ- [ FunD 'toPersistValue [ normalClause [] obj ]+ [ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ] , FunD 'fromPersistValue- [ normalClause [] (InfixE (Just fpv) compose $ Just getPersistMap')- ]+ [ normalClause [] fromPersistValueImplementation ] ] , persistFieldSqlInstanceD (mpsGeneric mps) typ- [ sqlTypeFunD ss+ [ sqlTypeFunD sqlStringConstructor' ] ] where- typ = genericDataType mps (entityHaskell e) backendT- entFields = entityFields e- columnNames = map (unpack . unHaskellName . fieldHaskell) entFields+ typ = genericDataType mps (entityHaskell entDef) backendT+ entFields = entityFields entDef+ columnNames = map (unpack . unHaskellName . fieldHaskell) entFields -- | Apply the given list of functions to the same @EntityDef@s. --
README.md view
@@ -15,7 +15,7 @@ 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'+stack test persistent-template --ghc-options='-ddump-splices -ddump-to-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'`)
bench/Main.hs view
@@ -18,8 +18,8 @@ main = defaultMain [ bgroup "mkPersist" [ bench "From File" $ nfIO $ mkPersist' $(persistFileWith lowerCaseSettings "bench/models-slowly")- --, bgroup "Non-Null Fields"- -- , bgroup "Increasing model count"+ -- , 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))@@ -32,7 +32,7 @@ -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1000)) -- ] -- ]- --, bgroup "Nullable"+ -- , bgroup "Nullable" -- [ bgroup "Increasing model count" -- [ bench "20x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 20 10)) -- , bench "40x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 40 10))
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.8.0+version: 2.8.0.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>