persistent-template 2.7.2 → 2.7.3
raw patch · 3 files changed
+264/−208 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +7/−0
- Database/Persist/TH.hs +256/−207
- persistent-template.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,10 @@+## Unreleased changes++## 2.7.3++* Update module documentation for `Database.Persist.TH` to better describe the purpose of the module [#968](https://github.com/yesodweb/persistent/pull/968)+* Support template-haskell-2.15 [#959](https://github.com/yesodweb/persistent/pull/959)+ ## 2.7.2 * Expose the knot tying logic of `parseReferences` so that users can build
Database/Persist/TH.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -8,8 +9,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} --- | This module provides utilities for creating backends. Regular users do not--- need to use this module.+-- | This module provides the tools for defining your database schema and using+-- it to generate Haskell data types and migrations. module Database.Persist.TH ( -- * Parse entity defs persistWith@@ -53,6 +54,7 @@ , Value (Object), (.:), (.:?) , eitherDecodeStrict' )+import qualified Data.ByteString as BS import Data.Char (toLower, toUpper) import qualified Data.HashMap.Strict as HM import Data.Int (Int64)@@ -60,19 +62,17 @@ 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 Data.Monoid ((<>), mappend, mconcat) 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(..))@@ -86,8 +86,10 @@ -- <https://github.com/yesodweb/persistent/issues/412> unHaskellNameForJSON :: HaskellName -> Text unHaskellNameForJSON = fixTypeUnderscore . unHaskellName- where fixTypeUnderscore "type" = "type_"- fixTypeUnderscore name = name+ where+ fixTypeUnderscore = \case+ "type" -> "type_"+ name -> name -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist).@@ -155,17 +157,14 @@ persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp persistManyFileWith ps fps = do mapM_ qAddDependentFile fps- ss <- mapM getS fps+ ss <- mapM (qRunIO . getFileContents) fps let s = T.intercalate "\n" ss -- be tolerant of the user forgetting to put a line-break at EOF. parseReferences ps s- where- getS fp = do- h <- qRunIO $ SIO.openFile fp SIO.ReadMode- qRunIO $ SIO.hSetEncoding h SIO.utf8_bom- s <- qRunIO $ TIO.hGetContents h- return s --- Takes a list of (potentially) independently defined entities and properly+getFileContents :: FilePath -> IO Text+getFileContents = fmap decodeUtf8 . BS.readFile++-- | Takes a list of (potentially) independently defined entities and properly -- links all foreign keys to reference the right 'EntityDef', tying the knot -- between entities. --@@ -182,48 +181,48 @@ noCycleEnts = map breakCycleEnt entsWithEmbeds -- every EntityDef could reference each-other (as an EmbedRef) -- let Haskell tie the knot- embedEntityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds+ embedEntityMap = constructEmbedEntityMap entsWithEmbeds entsWithEmbeds = map setEmbedEntity rawEnts setEmbedEntity ent = ent- { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent- }+ { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent+ } -- self references are already broken -- look at every emFieldEmbed to see if it refers to an already seen HaskellName -- so start with entityHaskell ent and accumulate embeddedHaskell em breakCycleEnt entDef =- let entName = entityHaskell entDef- in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef }+ let entName = entityHaskell entDef+ in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef } - breakCycleField entName f@(FieldDef { fieldReference = EmbedRef em }) =- f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }- breakCycleField _ f = f+ breakCycleField entName f = case f of+ FieldDef { fieldReference = EmbedRef em } ->+ f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }+ _ ->+ f breakCycleEmbed ancestors em =- em { embeddedFields = map (breakCycleEmField $ emName : ancestors)- (embeddedFields em)+ em { embeddedFields = breakCycleEmField (emName : ancestors) <$> embeddedFields em }- where- emName = embeddedHaskell em+ where+ emName = embeddedHaskell em breakCycleEmField ancestors emf = case embeddedHaskell <$> membed of Nothing -> emf Just embName -> if embName `elem` ancestors- then emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }- else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed }- where- membed = emFieldEmbed emf+ then emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }+ else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed }+ where+ membed = emFieldEmbed emf -- calls parse to Quasi.parse individual entities in isolation -- afterwards, sets references to other entities -- | @since 2.5.3 parseReferences :: PersistSettings -> Text -> Q Exp parseReferences ps s = lift $- map (mkEntityDefSqlTypeExp embedEntityMap entMap) noCycleEnts+ map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts where (embedEntityMap, noCycleEnts) = embedEntityDefsMap $ parse ps s- entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) noCycleEnts-+ entityMap = constructEntityMap noCycleEnts stripId :: FieldType -> Maybe Text stripId (FTTypeCon Nothing t) = stripSuffix "Id" t@@ -237,21 +236,23 @@ -- fieldSqlType at parse time can be an Exp -- This helps delay setting fieldSqlType until lift time-data EntityDefSqlTypeExp = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp]- deriving Show+data EntityDefSqlTypeExp+ = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp]+ deriving Show -data SqlTypeExp = SqlTypeExp FieldType- | SqlType' SqlType- deriving Show+data SqlTypeExp+ = SqlTypeExp FieldType+ | SqlType' SqlType+ deriving Show instance Lift SqlTypeExp where lift (SqlType' t) = lift t lift (SqlTypeExp ftype) = return st- where- typ = ftToType ftype- mtyp = (ConT ''Proxy `AppT` typ)- typedNothing = SigE (ConE 'Proxy) mtyp- st = VarE 'sqlType `AppE` typedNothing+ where+ typ = ftToType ftype+ mtyp = ConT ''Proxy `AppT` typ+ typedNothing = SigE (ConE 'Proxy) mtyp+ st = VarE 'sqlType `AppE` typedNothing data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp] @@ -260,9 +261,10 @@ lift $ zipWith FieldSqlTypeExp fields sqlTypeExps data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp+ instance Lift FieldSqlTypeExp where- lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) =- [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|]+ lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) =+ [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|] instance Lift EntityDefSqlTypeExp where lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =@@ -276,7 +278,7 @@ lift (ForeignRef name ft) = [|ForeignRef name ft|] lift (EmbedRef em) = [|EmbedRef em|] lift (CompositeRef cdef) = [|CompositeRef cdef|]- lift (SelfReference) = [|SelfReference|]+ lift SelfReference = [|SelfReference|] instance Lift EmbedEntityDef where lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|]@@ -285,99 +287,114 @@ lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|] type EmbedEntityMap = M.Map HaskellName EmbedEntityDef++constructEmbedEntityMap :: [EntityDef] -> EmbedEntityMap+constructEmbedEntityMap =+ M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent))+ type EntityMap = M.Map HaskellName EntityDef +constructEntityMap :: [EntityDef] -> EntityMap+constructEntityMap =+ M.fromList . fmap (\ent -> (entityHaskell ent, ent))+ data FTTypeConDescr = FTKeyCon deriving Show+ mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef mEmbedded _ (FTTypeCon Just{} _) = Left Nothing-mEmbedded ents (FTTypeCon Nothing n) = let name = HaskellName n in- maybe (Left Nothing) Right $ M.lookup name ents+mEmbedded ents (FTTypeCon Nothing n) =+ let name = HaskellName n+ in maybe (Left Nothing) Right $ M.lookup name ents mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded ents (FTApp x y) =- -- Key converts an Record to a RecordId- -- special casing this is obviously a hack- -- This problem may not be solvable with the current QuasiQuoted approach though- if x == FTTypeCon Nothing "Key"- then Left $ Just FTKeyCon- else mEmbedded ents y+ -- Key converts an Record to a RecordId+ -- special casing this is obviously a hack+ -- This problem may not be solvable with the current QuasiQuoted approach though+ if x == FTTypeCon Nothing "Key"+ then Left $ Just FTKeyCon+ else mEmbedded ents y setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef setEmbedField entName allEntities field = field- { fieldReference = case fieldReference field of- NoReference ->- case mEmbedded allEntities (fieldType field) of- Left _ -> case stripId $ fieldType field of- Nothing -> NoReference- Just name -> case M.lookup (HaskellName name) allEntities of- Nothing -> NoReference- Just _ -> ForeignRef (HaskellName name)- -- This can get corrected in mkEntityDefSqlTypeExp- (FTTypeCon (Just "Data.Int") "Int64")- Right em -> if embeddedHaskell em /= entName- then EmbedRef em- else if maybeNullable field- then SelfReference- else case fieldType field of- FTList _ -> SelfReference- _ -> error $ unpack $ unHaskellName entName- `Data.Monoid.mappend` ": a self reference must be a Maybe"- existing@_ -> existing+ { fieldReference =+ case fieldReference field of+ NoReference ->+ case mEmbedded allEntities (fieldType field) of+ Left _ ->+ case stripId $ fieldType field of+ Nothing -> NoReference+ Just name ->+ case M.lookup (HaskellName name) allEntities of+ Nothing -> NoReference+ Just _ -> ForeignRef (HaskellName name)+ -- This can get corrected in mkEntityDefSqlTypeExp+ (FTTypeCon (Just "Data.Int") "Int64")+ Right em ->+ if embeddedHaskell em /= entName+ then EmbedRef em+ else if maybeNullable field+ then SelfReference+ else case fieldType field of+ FTList _ -> SelfReference+ _ -> error $ unpack $ unHaskellName entName <> ": a self reference must be a Maybe"+ existing -> existing } mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp-mkEntityDefSqlTypeExp emEntities entMap ent = EntityDefSqlTypeExp ent- (getSqlType $ entityId ent)- $ (map getSqlType $ entityFields ent)+mkEntityDefSqlTypeExp emEntities entityMap ent =+ EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent) where- getSqlType field = maybe- (defaultSqlTypeExp field)- (SqlType' . SqlOther)- (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field)-+ getSqlType field =+ maybe+ (defaultSqlTypeExp field)+ (SqlType' . SqlOther)+ (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field) -- In the case of embedding, there won't be any datatype created yet. -- We just use SqlString, as the data will be serialized to JSON.- defaultSqlTypeExp field = case mEmbedded emEntities ftype of- Right _ -> SqlType' SqlString- Left (Just FTKeyCon) -> SqlType' SqlString- Left Nothing -> case fieldReference field of- ForeignRef refName ft -> case M.lookup refName entMap of- Nothing -> SqlTypeExp ft- -- A ForeignRef is blindly set to an Int64 in setEmbedField- -- correct that now- Just ent' -> case entityPrimary ent' of- Nothing -> SqlTypeExp ft- Just pdef -> case compositeFields pdef of- [] -> error "mkEntityDefSqlTypeExp: no composite fields"- [x] -> SqlTypeExp $ fieldType x- _ -> SqlType' $ SqlOther "Composite Reference"- CompositeRef _ -> SqlType' $ SqlOther "Composite Reference"- _ -> case ftype of- -- In the case of lists, we always serialize to a string- -- value (via JSON).- --- -- Normally, this would be determined automatically by- -- SqlTypeExp. However, there's one corner case: if there's- -- a list of entity IDs, the datatype for the ID has not- -- yet been created, so the compiler will fail. This extra- -- clause works around this limitation.- FTList _ -> SqlType' SqlString- _ -> SqlTypeExp ftype- where- ftype = fieldType field+ defaultSqlTypeExp field =+ case mEmbedded emEntities ftype of+ Right _ -> SqlType' SqlString+ Left (Just FTKeyCon) -> SqlType' SqlString+ Left Nothing -> case fieldReference field of+ ForeignRef refName ft -> case M.lookup refName entityMap of+ Nothing -> SqlTypeExp ft+ -- A ForeignRef is blindly set to an Int64 in setEmbedField+ -- correct that now+ Just ent' -> case entityPrimary ent' of+ Nothing -> SqlTypeExp ft+ Just pdef -> case compositeFields pdef of+ [] -> error "mkEntityDefSqlTypeExp: no composite fields"+ [x] -> SqlTypeExp $ fieldType x+ _ -> SqlType' $ SqlOther "Composite Reference"+ CompositeRef _ -> SqlType' $ SqlOther "Composite Reference"+ _ ->+ case ftype of+ -- In the case of lists, we always serialize to a string+ -- value (via JSON).+ --+ -- Normally, this would be determined automatically by+ -- SqlTypeExp. However, there's one corner case: if there's+ -- a list of entity IDs, the datatype for the ID has not+ -- yet been created, so the compiler will fail. This extra+ -- clause works around this limitation.+ FTList _ -> SqlType' SqlString+ _ -> SqlTypeExp ftype+ where+ ftype = fieldType field -- | Create data types and appropriate 'PersistEntity' instances for the given -- 'EntityDef's. Works well with the persist quasi-quoter. mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] mkPersist mps ents' = do x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents- y <- fmap mconcat $ mapM (mkEntity entMap mps) ents+ y <- fmap mconcat $ mapM (mkEntity entityMap mps) ents z <- fmap mconcat $ mapM (mkJSON mps) ents 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+ entityMap = constructEntityMap ents -- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. -- For example, strip out any fields marked as MigrationOnly.@@ -428,8 +445,9 @@ } -- | Create an @MkPersistSettings@ with default values.-mkPersistSettings :: Type -- ^ Value for 'mpsBackend'- -> MkPersistSettings+mkPersistSettings+ :: Type -- ^ Value for 'mpsBackend'+ -> MkPersistSettings mkPersistSettings t = MkPersistSettings { mpsBackend = t , mpsGeneric = False@@ -449,7 +467,8 @@ recNameNoUnderscore mps dt f | mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft | otherwise = lowerFirst ft- where ft = unHaskellName f+ where+ ft = unHaskellName f recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text recName mps dt f =@@ -518,11 +537,19 @@ uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec uniqueTypeDec mps t =+#if MIN_VERSION_template_haskell(2,15,0)+ DataInstD [] Nothing+ (AppT (ConT ''Unique) (genericDataType mps (entityHaskell t) backendT))+ Nothing+ (map (mkUnique mps t) $ entityUniques t)+ (derivClause $ entityUniques t)+#else DataInstD [] ''Unique [genericDataType mps (entityHaskell t) backendT] Nothing (map (mkUnique mps t) $ entityUniques t) (derivClause $ entityUniques t)+#endif where derivClause [] = [] #if MIN_VERSION_template_haskell(2,12,0)@@ -535,8 +562,8 @@ mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) = NormalC (mkName $ unpack constr) types where- types = map (go . flip lookup3 (entityFields t))- $ map (unHaskellName . fst) fields+ types =+ map (go . flip lookup3 (entityFields t) . unHaskellName . fst) fields force = "!force" `elem` attrs @@ -757,8 +784,6 @@ ] $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName) -- -- | declare the key type and associated instances -- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec])@@ -781,9 +806,14 @@ bi <- backendKeyI return (bi, allInstances) -#if MIN_VERSION_template_haskell(2,12,0)+#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] #else@@ -877,7 +907,7 @@ keyIdName = mkName . unpack . keyIdText keyIdText :: EntityDef -> Text-keyIdText t = (unHaskellName $ entityHaskell t) `mappend` "Id"+keyIdText t = unHaskellName (entityHaskell t) `mappend` "Id" unKeyName :: EntityDef -> Name unKeyName t = mkName $ "un" `mappend` keyString t@@ -914,7 +944,7 @@ keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)] keyFields mps t = case entityPrimary t of- Just pdef -> map primaryKeyVar $ (compositeFields pdef)+ Just pdef -> map primaryKeyVar (compositeFields pdef) Nothing -> if defaultIdType t then [idKeyVar backendKeyType] else [idKeyVar $ ftToType $ fieldType $ entityId t]@@ -931,8 +961,7 @@ keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name keyFieldName mps t fd | pkNewtype mps t = unKeyName t- | otherwise = mkName $ unpack- $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)+ | otherwise = mkName $ unpack $ lowerFirst (keyText t) `mappend` unHaskellName (fieldHaskell fd) mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec mkKeyToValues mps t = do@@ -956,8 +985,8 @@ mkKeyFromValues _mps t = do clauses <- case entityPrimary t of Nothing -> do- e <- [|fmap $(return $ keyConE) . fromPersistValue . headNote|]- return $ [normalClause [] e]+ e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]+ return [normalClause [] e] Just pdef -> fromValues t "keyFromValues" keyConE (compositeFields pdef) return $ FunD 'keyFromValues clauses@@ -965,61 +994,61 @@ keyConE = keyConExp t headNote :: [PersistValue] -> PersistValue-headNote (x:[]) = x-headNote xs = error $ "mkKeyFromValues: expected a list of one element, got: "- `mappend` show xs+headNote = \case+ [x] -> x+ xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause] fromValues t funName conE fields = do- x <- newName "x"- let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: "- patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]- suc <- patternSuccess- return [ suc, normalClause [VarP x] patternMatchFailure ]+ x <- newName "x"+ let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: "+ patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]+ suc <- patternSuccess+ return [ suc, normalClause [VarP x] patternMatchFailure ] where patternSuccess =- case fields of- [] -> do- rightE <- [|Right|]- return $ normalClause [ListP []] (rightE `AppE` conE)- _ -> do- x1 <- newName "x1"- restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields]- (fpv1:mkPersistValues) <- mapM mkPersistValue fields- app1E <- [|(<$>)|]- let conApp = infixFromPersistValue app1E fpv1 conE x1- applyE <- [|(<*>)|]- let applyFromPersistValue = infixFromPersistValue applyE+ case fields of+ [] -> do+ rightE <- [|Right|]+ return $ normalClause [ListP []] (rightE `AppE` conE)+ _ -> do+ x1 <- newName "x1"+ restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields]+ (fpv1:mkPersistValues) <- mapM mkPersistValue fields+ app1E <- [|(<$>)|]+ let conApp = infixFromPersistValue app1E fpv1 conE x1+ applyE <- [|(<*>)|]+ let applyFromPersistValue = infixFromPersistValue applyE - return $ normalClause- [ListP $ map VarP (x1:restNames)]- (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues))+ return $ normalClause+ [ListP $ map VarP (x1:restNames)]+ (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues)) infixFromPersistValue applyE fpv exp name =- UInfixE exp applyE (fpv `AppE` VarE name)+ UInfixE exp applyE (fpv `AppE` VarE name) mkPersistValue field =- [|mapLeft (fieldError t field) . fromPersistValue|]+ [|mapLeft (fieldError t field) . fromPersistValue|] fieldError :: EntityDef -> FieldDef -> Text -> Text fieldError entity field err = mconcat- [ "Couldn't parse field `"- , fieldName- , "` from table `"- , tableName- , "`. "- , err- ]+ [ "Couldn't parse field `"+ , fieldName+ , "` from table `"+ , tableName+ , "`. "+ , err+ ] where fieldName =- unHaskellName (fieldHaskell field)+ unHaskellName (fieldHaskell field) tableName =- unDBName (entityDB entity)+ unDBName (entityDB entity) mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]-mkEntity entMap mps t = do- t' <- liftAndFixKeys entMap t+mkEntity entityMap mps t = do+ t' <- liftAndFixKeys entityMap t let nameT = unHaskellName entName let nameS = unpack nameT let clazz = ConT ''PersistEntity `AppT` genDataType@@ -1055,7 +1084,7 @@ dtd : mconcat fkc `mappend` ([ TySynD (keyIdName t) [] $ ConT ''Key `AppT` ConT (mkName nameS)- , instanceD instanceConstraint clazz $+ , instanceD instanceConstraint clazz [ uniqueTypeDec mps t , keyTypeDec , keyToValues'@@ -1066,8 +1095,17 @@ , toFieldNames , utv , puk+#if MIN_VERSION_template_haskell(2,15,0) , DataInstD []+ Nothing+ (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ"))+ Nothing+ (map fst fields)+ []+#else+ , DataInstD+ [] ''EntityField [ genDataType , VarT $ mkName "typ"@@ -1075,12 +1113,21 @@ Nothing (map fst fields) []+#endif , FunD 'persistFieldDef (map snd fields)+#if MIN_VERSION_template_haskell(2,15,0) , TySynInstD+ (TySynEqn+ Nothing+ (AppT (ConT ''PersistEntityBackend) genDataType)+ (backendDataType mps))+#else+ , TySynInstD ''PersistEntityBackend (TySynEqn [genDataType] (backendDataType mps))+#endif , FunD 'persistIdField [normalClause [] (ConE $ keyIdName t)] , FunD 'fieldLens lensClauses ]@@ -1149,7 +1196,7 @@ singleUniqueKey :: Q [Dec] singleUniqueKey = do- expr <- [e|\p -> head (persistUniqueKeys p)|]+ expr <- [e| head . persistUniqueKeys|] let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]] cxt <- withPersistStoreWriteCxt pure [instanceD cxt onlyOneUniqueKeyClass impl]@@ -1159,7 +1206,7 @@ atLeastOneKey :: Q [Dec] atLeastOneKey = do- expr <- [e|\p -> NEL.fromList (persistUniqueKeys p)|]+ expr <- [e| NEL.fromList . persistUniqueKeys|] let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] cxt <- withPersistStoreWriteCxt pure [instanceD cxt atLeastOneUniqueKeyClass impl]@@ -1221,21 +1268,21 @@ mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] mkForeignKeysComposite mps t ForeignDef {..} = do- let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f- let fname = fieldName foreignConstraintNameHaskell- let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell- let reftableKeyName = mkName $ reftableString `mappend` "Key"- let tablename = mkName $ unpack $ entityText t- recordName <- newName "record"+ let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f+ let fname = fieldName foreignConstraintNameHaskell+ let reftableString = unpack $ unHaskellName foreignRefTableHaskell+ let reftableKeyName = mkName $ reftableString `mappend` "Key"+ let tablename = mkName $ unpack $ entityText t+ recordName <- newName "record" - let fldsE = map (\((foreignName, _),_) -> VarE (fieldName $ foreignName)- `AppE` VarE recordName) foreignFields- let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE- let fn = FunD fname [normalClause [VarP recordName] mkKeyE]+ let fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName)+ `AppE` VarE recordName) foreignFields+ let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE+ let fn = FunD fname [normalClause [VarP recordName] mkKeyE] - let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString)- let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2- return [sig, fn]+ let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString)+ let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2+ return [sig, fn] maybeExp :: Bool -> Exp -> Exp maybeExp may exp | may = fmapE `AppE` exp@@ -1244,8 +1291,6 @@ maybeTyp may typ | may = ConT ''Maybe `AppT` typ | otherwise = typ -- -- | produce code similar to the following: -- -- @@@ -1286,10 +1331,10 @@ [ sqlTypeFunD ss ] ]- where- typ = genericDataType mps (entityHaskell e) backendT- entFields = entityFields e- columnNames = map (unpack . unHaskellName . fieldHaskell) entFields+ where+ typ = genericDataType mps (entityHaskell e) backendT+ entFields = entityFields e+ columnNames = map (unpack . unHaskellName . fieldHaskell) entFields -- | Apply the given list of functions to the same @EntityDef@s. --@@ -1297,7 +1342,7 @@ -- -- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]-share fs x = fmap mconcat $ mapM ($ x) fs+share fs x = mconcat <$> mapM ($ x) fs -- | Save the @EntityDef@s passed in under the given name. mkSave :: String -> [EntityDef] -> Q [Dec]@@ -1532,9 +1577,9 @@ ] where defs = filter isMigrated allDefs- isMigrated def = not $ "no-migrate" `elem` entityAttrs def+ isMigrated def = "no-migrate" `notElem` entityAttrs def typ = ConT ''Migration- entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) allDefs+ entityMap = constructEntityMap allDefs body :: Q Exp body = case defs of@@ -1542,40 +1587,40 @@ _ -> do defsName <- newName "defs" defsStmt <- do- defs' <- mapM (liftAndFixKeys entMap) defs+ defs' <- mapM (liftAndFixKeys entityMap) defs let defsExp = ListE defs' return $ LetS [ValD (VarP defsName) (NormalB defsExp) []] stmts <- mapM (toStmt $ VarE defsName) defs return (DoE $ defsStmt : stmts) toStmt :: Exp -> EntityDef -> Q Stmt toStmt defsExp ed = do- u <- liftAndFixKeys entMap ed+ u <- liftAndFixKeys entityMap ed m <- [|migrate|] return $ NoBindS $ m `AppE` defsExp `AppE` u liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp-liftAndFixKeys entMap EntityDef{..} =- [|EntityDef- entityHaskell- entityDB- entityId- entityAttrs- $(ListE <$> mapM (liftAndFixKey entMap) entityFields)- entityUniques- entityForeigns- entityDerives- entityExtra- entitySum- entityComments- |]+liftAndFixKeys entityMap EntityDef{..} =+ [|EntityDef+ entityHaskell+ entityDB+ entityId+ entityAttrs+ $(ListE <$> mapM (liftAndFixKey entityMap) entityFields)+ entityUniques+ entityForeigns+ entityDerives+ entityExtra+ entitySum+ entityComments+ |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp-liftAndFixKey entMap (FieldDef a b c sqlTyp e f fieldRef mcomments) =- [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|]+liftAndFixKey entityMap (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- ForeignRef refName _ft -> case M.lookup refName entMap of+ ForeignRef refName _ft -> case M.lookup refName entityMap of Nothing -> Nothing Just ent -> case fieldReference $ entityId ent of@@ -1598,12 +1643,16 @@ entitySum entityComments |]+ instance Lift FieldDef where 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 lift (CompositeDef a b) = [|CompositeDef a b|]+ instance Lift ForeignDef where lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|] @@ -1730,7 +1779,7 @@ (++) = append mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]-mkJSON _ def | not ("json" `elem` entityAttrs def) = return []+mkJSON _ def | ("json" `notElem` entityAttrs def) = return [] mkJSON mps def = do pureE <- [|pure|] apE' <- [|(<*>)|]
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.7.2+version: 2.7.3 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>