{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | 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 , persistUpperCase , persistLowerCase , persistFileWith , persistManyFileWith -- * Turn @EntityDef@s into types , mkPersist , mkPersistWith , MkPersistSettings , mpsBackend , mpsGeneric , mpsPrefixFields , mpsFieldLabelModifier , mpsConstraintLabelModifier , mpsEntityJSON , mpsGenerateLenses , mpsDeriveInstances , EntityJSON(..) , mkPersistSettings , sqlSettings -- ** Implicit ID Columns , ImplicitIdDef , setImplicitIdDef -- * Various other TH functions , mkMigrate , migrateModels , discoverEntities , mkEntityDefList , share , derivePersistField , derivePersistFieldJSON , persistFieldFromEntity -- * Internal , lensPTH , parseReferences , embedEntityDefs , fieldError , AtLeastOneUniqueKey(..) , OnlyOneUniqueKey(..) , pkNewtype ) 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 (concat, exp, splitAt, take, (++)) import Control.Monad import Data.Aeson ( FromJSON(parseJSON) , ToJSON(toJSON) , Value(Object) , eitherDecodeStrict' , object , withObject , (.:) , (.:?) , (.=) ) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as Key #endif import qualified Data.ByteString as BS import Data.Char (toLower, toUpper) import Data.Coerce import Data.Data (Data) import Data.Either import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.Ix (Ix) import Data.List (foldl') import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as TE import Data.Typeable (Typeable) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import GHC.TypeLits import Instances.TH.Lift () -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` import Data.Foldable (toList) import qualified Data.Set as Set import Language.Haskell.TH.Lib (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Web.PathPieces (PathPiece(..)) import Database.Persist.Class.PersistEntity import Database.Persist import Database.Persist.Quasi import Database.Persist.Quasi.Internal import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) import Database.Persist.EntityDef.Internal (EntityDef(..)) import Database.Persist.ImplicitIdDef (autoIncrementingInteger) import Database.Persist.ImplicitIdDef.Internal #if MIN_VERSION_template_haskell(2,18,0) conp :: Name -> [Pat] -> Pat conp name pats = ConP name [] pats #else conp = ConP #endif -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). persistWith :: PersistSettings -> QuasiQuoter persistWith ps = QuasiQuoter { quoteExp = parseReferences ps . pack , quotePat = error "persistWith can't be used as pattern" , quoteType = error "persistWith can't be used as type" , quoteDec = error "persistWith can't be used as declaration" } -- | Apply 'persistWith' to 'upperCaseSettings'. persistUpperCase :: QuasiQuoter persistUpperCase = persistWith upperCaseSettings -- | Apply 'persistWith' to 'lowerCaseSettings'. persistLowerCase :: QuasiQuoter persistLowerCase = persistWith lowerCaseSettings -- | Same as 'persistWith', but uses an external file instead of a -- 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 -- potentially dramatically speed up compile times. -- -- The recommended file extension is @.persistentmodels@. -- -- ==== __Examples__ -- -- Split your Persistent definitions into multiple files (@models1@, @models2@), -- then create a new module for each new file and run 'mkPersist' there: -- -- @ -- -- Model1.hs -- 'share' -- ['mkPersist' 'sqlSettings'] -- $('persistFileWith' 'lowerCaseSettings' "models1") -- @ -- @ -- -- Model2.hs -- 'share' -- ['mkPersist' 'sqlSettings'] -- $('persistFileWith' 'lowerCaseSettings' "models2") -- @ -- -- Use 'persistManyFileWith' to create your migrations: -- -- @ -- -- Migrate.hs -- 'share' -- ['mkMigrate' "migrateAll"] -- $('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, -- but so far we've only seen mild reductions. -- -- See and -- for more details. -- -- @since 2.5.4 persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp persistManyFileWith ps fps = do mapM_ qAddDependentFile 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 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. -- -- Allows users to define entities indepedently or in separate modules and then -- fix the cross-references between them at runtime to create a 'Migration'. -- -- @since 2.7.2 embedEntityDefs :: [EntityDef] -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' -- call. -- -- @since 2.13.0.0 -> [UnboundEntityDef] -> [UnboundEntityDef] embedEntityDefs eds = snd . embedEntityDefsMap eds embedEntityDefsMap :: [EntityDef] -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' -- call. -- -- @since 2.13.0.0 -> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef]) embedEntityDefsMap existingEnts rawEnts = (embedEntityMap, noCycleEnts) where noCycleEnts = entsWithEmbeds embedEntityMap = constructEmbedEntityMap entsWithEmbeds entsWithEmbeds = fmap setEmbedEntity (rawEnts <> map unbindEntityDef existingEnts) setEmbedEntity ubEnt = let ent = unboundEntityDef ubEnt in ubEnt { unboundEntityDef = overEntityFields (fmap (setEmbedField (entityHaskell ent) embedEntityMap)) ent } -- | Calls 'parse' to Quasi.parse individual entities in isolation -- afterwards, sets references to other entities -- -- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@ -- instead of @['EntityDef']@. -- -- @since 2.5.3 parseReferences :: PersistSettings -> Text -> Q Exp parseReferences ps s = lift $ parse ps s preprocessUnboundDefs :: [EntityDef] -> [UnboundEntityDef] -> (M.Map EntityNameHS (), [UnboundEntityDef]) preprocessUnboundDefs preexistingEntities unboundDefs = (embedEntityMap, noCycleEnts) where (embedEntityMap, noCycleEnts) = embedEntityDefsMap preexistingEntities unboundDefs stripId :: FieldType -> Maybe Text stripId (FTTypeCon Nothing t) = stripSuffix "Id" t stripId _ = Nothing liftAndFixKeys :: MkPersistSettings -> M.Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp liftAndFixKeys mps emEntities entityMap unboundEnt = let ent = unboundEntityDef unboundEnt fields = getUnboundFieldDefs unboundEnt in [| ent { entityFields = $(ListE <$> traverse combinedFixFieldDef fields) , entityId = $(fixPrimarySpec mps unboundEnt) , entityForeigns = $(fixUnboundForeignDefs (unboundForeignDefs unboundEnt)) } |] where fixUnboundForeignDefs :: [UnboundForeignDef] -> Q Exp fixUnboundForeignDefs fdefs = fmap ListE $ forM fdefs fixUnboundForeignDef where fixUnboundForeignDef UnboundForeignDef{..} = [| unboundForeignDef { foreignFields = $(lift fixForeignFields) , foreignNullable = $(lift fixForeignNullable) , foreignRefTableDBName = $(lift fixForeignRefTableDBName) } |] where fixForeignRefTableDBName = entityDB (unboundEntityDef parentDef) foreignFieldNames = case unboundForeignFields of FieldListImpliedId ffns -> ffns FieldListHasReferences references -> fmap ffrSourceField references parentDef = case M.lookup parentTableName entityMap of Nothing -> error $ mconcat [ "Foreign table not defined: " , show parentTableName ] Just a -> a parentTableName = foreignRefTableHaskell unboundForeignDef fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)] fixForeignFields = case unboundForeignFields of FieldListImpliedId ffns -> mkReferences $ toList ffns FieldListHasReferences references -> toList $ fmap convReferences references where -- in this case, we're up against the implied ID of the parent -- dodgy assumption: columns are listed in the right order. we -- can't check this any more clearly right now. mkReferences fieldNames | length fieldNames /= length parentKeyFieldNames = error $ mconcat [ "Foreign reference needs to have the same number " , "of fields as the target table." , "\n Table : " , show (getUnboundEntityNameHS unboundEnt) , "\n Foreign Table: " , show parentTableName , "\n Fields : " , show fieldNames , "\n Parent fields: " , show (fmap fst parentKeyFieldNames) , "\n\nYou can use the References keyword to fix this." ] | otherwise = zip (fmap (withDbName fieldStore) fieldNames) (toList parentKeyFieldNames) where parentKeyFieldNames :: NonEmpty (FieldNameHS, FieldNameDB) parentKeyFieldNames = case unboundPrimarySpec parentDef of NaturalKey ucd -> fmap (withDbName parentFieldStore) (unboundCompositeCols ucd) SurrogateKey uid -> pure (FieldNameHS "Id", unboundIdDBName uid) DefaultKey dbName -> pure (FieldNameHS "Id", dbName) withDbName store fieldNameHS = ( fieldNameHS , findDBName store fieldNameHS ) convReferences :: ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef) convReferences ForeignFieldReference {..} = ( withDbName fieldStore ffrSourceField , withDbName parentFieldStore ffrTargetField ) fixForeignNullable = all ((NotNullable /=) . isForeignNullable) foreignFieldNames where isForeignNullable fieldNameHS = case getFieldDef fieldNameHS fieldStore of Nothing -> error "Field name not present in map" Just a -> isUnboundFieldNullable a fieldStore = mkFieldStore unboundEnt parentFieldStore = mkFieldStore parentDef findDBName store fieldNameHS = case getFieldDBName fieldNameHS store of Nothing -> error $ mconcat [ "findDBName: failed to fix dbname for: " , show fieldNameHS ] Just a-> a combinedFixFieldDef :: UnboundFieldDef -> Q Exp combinedFixFieldDef ufd@UnboundFieldDef{..} = [| FieldDef { fieldHaskell = unboundFieldNameHS , fieldDB = unboundFieldNameDB , fieldType = unboundFieldType , fieldSqlType = $(sqlTyp') , fieldAttrs = unboundFieldAttrs , fieldStrict = unboundFieldStrict , fieldReference = $(fieldRef') , fieldCascade = unboundFieldCascade , fieldComments = unboundFieldComments , fieldGenerated = unboundFieldGenerated , fieldIsImplicitIdColumn = False } |] where sqlTypeExp = getSqlType emEntities entityMap ufd FieldDef _x _ _ _ _ _ _ _ _ _ _ = error "need to update this record wildcard match" (fieldRef', sqlTyp') = case extractForeignRef entityMap ufd of Just targetTable -> (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTable)) Nothing -> (lift NoReference, liftSqlTypeExp sqlTypeExp) data FieldStore = FieldStore { fieldStoreMap :: M.Map FieldNameHS UnboundFieldDef , fieldStoreId :: Maybe FieldNameDB , fieldStoreEntity :: UnboundEntityDef } mkFieldStore :: UnboundEntityDef -> FieldStore mkFieldStore ued = FieldStore { fieldStoreEntity = ued , fieldStoreMap = M.fromList $ fmap (\ufd -> ( unboundFieldNameHS ufd , ufd ) ) $ getUnboundFieldDefs $ ued , fieldStoreId = case unboundPrimarySpec ued of NaturalKey _ -> Nothing SurrogateKey fd -> Just $ unboundIdDBName fd DefaultKey n -> Just n } getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB getFieldDBName name fs | FieldNameHS "Id" == name = fieldStoreId fs | otherwise = unboundFieldNameDB <$> getFieldDef name fs getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef getFieldDef fieldNameHS fs = M.lookup fieldNameHS (fieldStoreMap fs) extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS extractForeignRef entityMap fieldDef = do refName <- guessFieldReference fieldDef ent <- M.lookup refName entityMap pure $ entityHaskell $ unboundEntityDef ent guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS guessFieldReference = guessReference . unboundFieldType guessReference :: FieldType -> Maybe EntityNameHS guessReference ft = case ft of FTTypeCon Nothing (T.stripSuffix "Id" -> Just tableName) -> Just (EntityNameHS tableName) FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing tableName) -> Just (EntityNameHS tableName) _ -> Nothing mkDefaultKey :: MkPersistSettings -> FieldNameDB -> EntityNameHS -> FieldDef mkDefaultKey mps pk unboundHaskellName = let iid = mpsImplicitIdDef mps in maybe id addFieldAttr (FieldAttrDefault <$> iidDefault iid) $ maybe id addFieldAttr (FieldAttrMaxlen <$> iidMaxLen iid) $ mkAutoIdField' pk unboundHaskellName (iidFieldSqlType iid) fixPrimarySpec :: MkPersistSettings -> UnboundEntityDef -> Q Exp fixPrimarySpec mps unboundEnt= do case unboundPrimarySpec unboundEnt of DefaultKey pk -> lift $ EntityIdField $ mkDefaultKey mps pk unboundHaskellName SurrogateKey uid -> do let entNameHS = getUnboundEntityNameHS unboundEnt fieldTyp = fromMaybe (mkKeyConType entNameHS) (unboundIdType uid) [| EntityIdField FieldDef { fieldHaskell = FieldNameHS "Id" , fieldDB = $(lift $ getSqlNameOr (unboundIdDBName uid) (unboundIdAttrs uid)) , fieldType = $(lift fieldTyp) , fieldSqlType = $( liftSqlTypeExp (SqlTypeExp fieldTyp) ) , fieldStrict = False , fieldReference = ForeignRef entNameHS , fieldAttrs = unboundIdAttrs uid , fieldComments = Nothing , fieldCascade = unboundIdCascade uid , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } |] NaturalKey ucd -> [| EntityIdNaturalKey $(bindCompositeDef unboundEnt ucd) |] where unboundHaskellName = getUnboundEntityNameHS unboundEnt bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp bindCompositeDef ued ucd = do fieldDefs <- fmap ListE $ forM (toList $ unboundCompositeCols ucd) $ \col -> mkLookupEntityField ued col [| CompositeDef { compositeFields = NEL.fromList $(pure fieldDefs) , compositeAttrs = $(lift $ unboundCompositeAttrs ucd) } |] getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp getSqlType emEntities entityMap field = maybe (defaultSqlTypeExp emEntities entityMap field) (SqlType' . SqlOther) (listToMaybe $ mapMaybe attrSqlType $ unboundFieldAttrs 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 :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp defaultSqlTypeExp emEntities entityMap field = case mEmbedded emEntities ftype of Right _ -> SqlType' SqlString Left (Just (FTKeyCon ty)) -> SqlTypeExp (FTTypeCon Nothing ty) Left Nothing -> case extractForeignRef entityMap field of Just refName -> case M.lookup refName entityMap of Nothing -> -- error $ mconcat -- [ "Failed to find model: " -- , show refName -- , " in entity list: \n" -- ] -- <> (unlines $ map show $ M.keys $ entityMap) -- going to assume that it's fine, will reify it out -- right later anyway) SqlTypeExp ftype -- A ForeignRef is blindly set to an Int64 in setEmbedField -- correct that now Just _ -> SqlTypeReference refName _ -> 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 = unboundFieldType field attrSqlType :: FieldAttr -> Maybe Text attrSqlType = \case FieldAttrSqltype x -> Just x _ -> Nothing data SqlTypeExp = SqlTypeExp FieldType | SqlType' SqlType | SqlTypeReference EntityNameHS deriving Show liftSqlTypeExp :: SqlTypeExp -> Q Exp liftSqlTypeExp ste = case ste of SqlType' t -> lift t SqlTypeExp ftype -> do let typ = ftToType ftype mtyp = ConT ''Proxy `AppT` typ typedNothing = SigE (ConE 'Proxy) mtyp pure $ VarE 'sqlType `AppE` typedNothing SqlTypeReference entNameHs -> do let entNameId :: Name entNameId = mkName $ T.unpack (unEntityNameHS entNameHs) <> "Id" [| sqlType (Proxy :: Proxy $(conT entNameId)) |] type EmbedEntityMap = M.Map EntityNameHS () constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap constructEmbedEntityMap = M.fromList . fmap (\ent -> ( entityHaskell (unboundEntityDef ent) -- , toEmbedEntityDef (unboundEntityDef ent) , () ) ) lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS lookupEmbedEntity allEntities field = do entName <- EntityNameHS <$> stripId (fieldType field) guard (M.member entName allEntities) -- check entity name exists in embed fmap pure entName type EntityMap = M.Map EntityNameHS UnboundEntityDef constructEntityMap :: [UnboundEntityDef] -> EntityMap constructEntityMap = M.fromList . fmap (\ent -> (entityHaskell (unboundEntityDef ent), ent)) data FTTypeConDescr = FTKeyCon Text deriving Show -- | Recurses through the 'FieldType'. Returns a 'Right' with the -- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of -- a name and that name is present in the 'EmbedEntityMap' provided as -- a first argument. -- -- If the 'FieldType' represents a @Key something@, this returns a @'Left -- ('Just' 'FTKeyCon')@. -- -- If the 'FieldType' has a module qualified value, then it returns @'Left' -- 'Nothing'@. mEmbedded :: M.Map EntityNameHS a -> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS mEmbedded _ (FTTypeCon Just{} _) = Left Nothing mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = maybe (Left Nothing) (\_ -> Right name) $ M.lookup name ents mEmbedded _ (FTTypePromoted _) = Left Nothing mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded _ (FTApp (FTTypeCon Nothing "Key") (FTTypeCon _ a)) = Left $ Just $ FTKeyCon $ a <> "Id" mEmbedded _ (FTApp _ _) = Left Nothing setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef setEmbedField entName allEntities field = case fieldReference field of NoReference -> setFieldReference ref field _ -> field where ref = case mEmbedded allEntities (fieldType field) of Left _ -> fromMaybe NoReference $ do refEntName <- lookupEmbedEntity allEntities field pure $ ForeignRef refEntName Right em -> if em /= entName then EmbedRef em else if maybeNullable (unbindFieldDef field) then SelfReference else case fieldType field of FTList _ -> SelfReference _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe or List" setFieldReference :: ReferenceDef -> FieldDef -> FieldDef setFieldReference ref field = field { fieldReference = ref } -- | Create data types and appropriate 'PersistEntity' instances for the given -- 'EntityDef's. Works well with the persist quasi-quoter. mkPersist :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec] mkPersist mps = mkPersistWith mps [] -- | Like ' -- -- @since 2.13.0.0 mkPersistWith :: MkPersistSettings -> [EntityDef] -> [UnboundEntityDef] -> Q [Dec] mkPersistWith mps preexistingEntities ents' = do let (embedEntityMap, predefs) = preprocessUnboundDefs preexistingEntities ents' allEnts = embedEntityDefs preexistingEntities $ fmap (setDefaultIdFields mps) $ predefs entityMap = constructEntityMap allEnts preexistingSet = Set.fromList $ map getEntityHaskellName preexistingEntities newEnts = filter (\e -> getUnboundEntityNameHS e `Set.notMember` preexistingSet) allEnts ents <- filterM shouldGenerateCode newEnts requireExtensions [ [TypeFamilies], [GADTs, ExistentialQuantification] , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] , [UndecidableInstances], [DataKinds], [FlexibleInstances] ] persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents safeToInsertInstances <- mconcat <$> mapM (mkSafeToInsertInstance mps) ents symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents return $ mconcat [ persistFieldDecs , entityDecs , jsonDecs , uniqueKeyInstances , symbolToFieldInstances , safeToInsertInstances ] mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] mkSafeToInsertInstance mps ued = case unboundPrimarySpec ued of NaturalKey _ -> instanceOkay SurrogateKey uidDef -> do let attrs = unboundIdAttrs uidDef isDefaultFieldAttr = \case FieldAttrDefault _ -> True _ -> False case List.find isDefaultFieldAttr attrs of Nothing -> badInstance Just _ -> instanceOkay DefaultKey _ -> instanceOkay where typ :: Type typ = genericDataType mps (getUnboundEntityNameHS ued) backendT mkInstance merr = InstanceD Nothing (maybe id (:) merr withPersistStoreWriteCxt) (ConT ''SafeToInsert `AppT` typ) [] instanceOkay = pure [ mkInstance Nothing ] badInstance = do err <- [t| TypeError (SafeToInsertErrorMessage $(pure typ)) |] pure [ mkInstance (Just err) ] withPersistStoreWriteCxt = if mpsGeneric mps then [ConT ''PersistStoreWrite `AppT` backendT] else [] -- we can't just use 'isInstance' because TH throws an error shouldGenerateCode :: UnboundEntityDef -> Q Bool shouldGenerateCode ed = do mtyp <- lookupTypeName entityName case mtyp of Nothing -> do pure True Just typeName -> do instanceExists <- isInstance ''PersistEntity [ConT typeName] pure (not instanceExists) where entityName = T.unpack . unEntityNameHS . getEntityHaskellName . unboundEntityDef $ ed overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef overEntityDef f ued = ued { unboundEntityDef = f (unboundEntityDef ued) } setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef setDefaultIdFields mps ued | defaultIdType ued = overEntityDef (setEntityIdDef (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed))) ued | otherwise = ued where ed = unboundEntityDef ued setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef setToMpsDefault iid (EntityIdField fd) = EntityIdField fd { fieldType = iidFieldType iid (getEntityHaskellName ed) , fieldSqlType = iidFieldSqlType iid , fieldAttrs = let def = toList (FieldAttrDefault <$> iidDefault iid) maxlen = toList (FieldAttrMaxlen <$> iidMaxLen iid) in def <> maxlen <> fieldAttrs fd , fieldIsImplicitIdColumn = True } setToMpsDefault _ x = x -- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. -- For example, strip out any fields marked as MigrationOnly. -- -- This should be called when performing Haskell codegen, but the 'EntityDef' -- *should* keep all of the fields present when defining 'entityDef'. This is -- necessary so that migrations know to keep these columns around, or to delete -- them, as appropriate. fixEntityDef :: UnboundEntityDef -> UnboundEntityDef fixEntityDef ued = ued { unboundEntityFields = filter isHaskellUnboundField (unboundEntityFields ued) } -- | Settings to be passed to the 'mkPersist' function. data MkPersistSettings = MkPersistSettings { mpsBackend :: Type -- ^ Which database backend we\'re using. This type is used for the -- 'PersistEntityBackend' associated type in the entities that are -- generated. -- -- If the 'mpsGeneric' value is set to 'True', then this type is used for -- the non-Generic type alias. The data and type will be named: -- -- @ -- data ModelGeneric backend = Model { ... } -- @ -- -- And, for convenience's sake, we provide a type alias: -- -- @ -- type Model = ModelGeneric $(the type you give here) -- @ , mpsGeneric :: Bool -- ^ Create generic types that can be used with multiple backends. Good for -- reusable code, but makes error messages harder to understand. Default: -- False. , mpsPrefixFields :: Bool -- ^ Prefix field names with the model name. Default: True. -- -- Note: this field is deprecated. Use the mpsFieldLabelModifier and -- 'mpsConstraintLabelModifier' instead. , mpsFieldLabelModifier :: Text -> Text -> Text -- ^ Customise the field accessors and lens names using the entity and field -- name. Both arguments are upper cased. -- -- Default: appends entity and field. -- -- Note: this setting is ignored if mpsPrefixFields is set to False. -- -- @since 2.11.0.0 , mpsConstraintLabelModifier :: Text -> Text -> Text -- ^ Customise the Constraint names using the entity and field name. The -- result should be a valid haskell type (start with an upper cased letter). -- -- Default: appends entity and field -- -- Note: this setting is ignored if mpsPrefixFields is set to False. -- -- @since 2.11.0.0 , mpsEntityJSON :: Maybe EntityJSON -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's -- @Nothing@, no instances will be generated. Default: -- -- @ -- Just 'EntityJSON' -- { 'entityToJSON' = 'entityIdToJSON -- , 'entityFromJSON' = 'entityIdFromJSON -- } -- @ , mpsGenerateLenses :: Bool -- ^ Instead of generating normal field accessors, generator lens-style -- accessors. -- -- Default: False -- -- @since 1.3.1 , mpsDeriveInstances :: [Name] -- ^ Automatically derive these typeclass instances for all record and key -- types. -- -- Default: [] -- -- @since 2.8.1 , mpsImplicitIdDef :: ImplicitIdDef -- ^ TODO: document -- -- @since 2.13.0.0 } {-# DEPRECATED mpsGeneric "The mpsGeneric function adds a considerable amount of overhead and complexity to the library without bringing significant benefit. We would like to remove it. If you require this feature, please comment on the linked GitHub issue, and we'll either keep it around, or we can figure out a nicer way to solve your problem.\n\n Github: https://github.com/yesodweb/persistent/issues/1204" #-} -- | Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default -- value is 'autoIncrementingInteger'. -- -- @since 2.13.0.0 setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings setImplicitIdDef iid mps = mps { mpsImplicitIdDef = iid } getImplicitIdType :: MkPersistSettings -> Type getImplicitIdType = do idDef <- mpsImplicitIdDef isGeneric <- mpsGeneric backendTy <- mpsBackend pure $ iidType idDef isGeneric backendTy data EntityJSON = EntityJSON { entityToJSON :: Name -- ^ Name of the @toJSON@ implementation for @Entity a@. , entityFromJSON :: Name -- ^ Name of the @fromJSON@ implementation for @Entity a@. } -- | Create an @MkPersistSettings@ with default values. mkPersistSettings :: Type -- ^ Value for 'mpsBackend' -> MkPersistSettings mkPersistSettings backend = MkPersistSettings { mpsBackend = backend , mpsGeneric = False , mpsPrefixFields = True , mpsFieldLabelModifier = (++) , mpsConstraintLabelModifier = (++) , mpsEntityJSON = Just EntityJSON { entityToJSON = 'entityIdToJSON , entityFromJSON = 'entityIdFromJSON } , mpsGenerateLenses = False , mpsDeriveInstances = [] , mpsImplicitIdDef = autoIncrementingInteger } -- | Use the 'SqlPersist' backend. sqlSettings :: MkPersistSettings sqlSettings = mkPersistSettings $ ConT ''SqlBackend lowerFirst :: Text -> Text lowerFirst t = case uncons t of Just (a, b) -> cons (toLower a) b Nothing -> t upperFirst :: Text -> Text upperFirst t = case uncons t of Just (a, b) -> cons (toUpper a) b Nothing -> t dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec dataTypeDec mps entityMap entDef = do let names = mkEntityDefDeriveNames mps entDef let (stocks, anyclasses) = partitionEithers (fmap stratFor names) let stockDerives = do guard (not (null stocks)) pure (DerivClause (Just StockStrategy) (fmap ConT stocks)) anyclassDerives = do guard (not (null anyclasses)) pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses)) unless (null anyclassDerives) $ do requireExtensions [[DeriveAnyClass]] pure $ DataD [] nameFinal paramsFinal Nothing constrs (stockDerives <> anyclassDerives) where stratFor n = if n `elem` stockClasses then Left n else Right n stockClasses = Set.fromList (fmap mkName [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable" ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable ] ) (nameFinal, paramsFinal) | mpsGeneric mps = ( mkEntityDefGenericName entDef , [ mkPlainTV backendName ] ) | otherwise = (mkEntityDefName entDef, []) cols :: [VarBangType] cols = do fieldDef <- getUnboundFieldDefs entDef let recordName = fieldDefToRecordName mps entDef fieldDef strictness = if unboundFieldStrict fieldDef then isStrict else notStrict fieldIdType = maybeIdType mps entityMap fieldDef Nothing Nothing pure (recordName, strictness, fieldIdType) constrs | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef | otherwise = [RecC (mkEntityDefName entDef) cols] sumCon fieldDef = NormalC (sumConstrName mps entDef fieldDef) [(notStrict, maybeIdType mps entityMap fieldDef Nothing Nothing)] uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec uniqueTypeDec mps entityMap entDef = DataInstD [] #if MIN_VERSION_template_haskell(2,15,0) Nothing (AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT)) #else ''Unique [genericDataType mps (getUnboundEntityNameHS entDef) backendT] #endif Nothing (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef)) [] mkUnique :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) = NormalC (mkConstraintName constr) $ toList types where types = fmap (go . flip lookup3 (getUnboundFieldDefs entDef) . unFieldNameHS . fst) fields force = "!force" `elem` attrs go :: (UnboundFieldDef, IsNullable) -> (Strict, Type) go (_, Nullable _) | not force = error nullErrMsg go (fd, y) = (notStrict, maybeIdType mps entityMap fd Nothing (Just y)) lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable) lookup3 s [] = error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr lookup3 x (fd:rest) | x == unFieldNameHS (unboundFieldNameHS fd) = (fd, isUnboundFieldNullable fd) | otherwise = lookup3 x rest nullErrMsg = mconcat [ "Error: By default we disallow NULLables in an uniqueness " , "constraint. The semantics of how NULL interacts with those " , "constraints is non-trivial: two NULL values are not " , "considered equal for the purposes of an uniqueness " , "constraint. If you understand this feature, it is possible " , "to use it your advantage. *** Use a \"!force\" attribute " , "on the end of the line that defines your uniqueness " , "constraint in order to disable this check. ***" ] -- | This function renders a Template Haskell 'Type' for an 'UnboundFieldDef'. -- It takes care to respect the 'mpsGeneric' setting to render an Id faithfully, -- and it also ensures that the generated Haskell type is 'Maybe' if the -- database column has that attribute. -- -- For a database schema with @'mpsGeneric' = False@, this is simple - it uses -- the @ModelNameId@ type directly. This resolves just fine. -- -- If 'mpsGeneric' is @True@, then we have to do something a bit more -- complicated. We can't refer to a @ModelNameId@ directly, because that @Id@ -- alias hides the backend type variable. Instead, we need to refer to: -- -- > Key (ModelNameGeneric backend) -- -- This means that the client code will need both the term @ModelNameId@ in -- scope, as well as the @ModelNameGeneric@ constructor, despite the fact that -- the @ModelNameId@ is the only term explicitly used (and imported). -- -- However, we're not guaranteed to have @ModelName@ in scope - we've only -- referenced @ModelNameId@ in code, and so code generation *should* work even -- without this. Consider an explicit-style import: -- -- @ -- import Model.Foo (FooId) -- -- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| -- Bar -- foo FooId -- |] -- @ -- -- This looks like it ought to work, but it would fail with @mpsGeneric@ being -- enabled. One hacky work-around is to perform a @'lookupTypeName' :: String -> -- Q (Maybe Name)@ on the @"ModelNameId"@ type string. If the @Id@ is -- a reference in the 'EntityMap' and @lookupTypeName@ returns @'Just' name@, -- then that 'Name' contains the fully qualified information needed to use the -- 'Name' without importing it at the client-site. Then we can perform a bit of -- surgery on the 'Name' to strip the @Id@ suffix, turn it into a 'Type', and -- apply the 'Key' constructor. maybeIdType :: MkPersistSettings -> EntityMap -> UnboundFieldDef -> Maybe Name -- ^ backend -> Maybe IsNullable -> Type maybeIdType mps entityMap fieldDef mbackend mnull = maybeTyp mayNullable idType where mayNullable = case mnull of Just (Nullable ByMaybeAttr) -> True _ -> maybeNullable fieldDef idType = fromMaybe (ftToType $ unboundFieldType fieldDef) $ do typ <- extractForeignRef entityMap fieldDef guard ((mpsGeneric mps)) pure $ ConT ''Key `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) -- TODO: if we keep mpsGeneric, this needs to check 'mpsGeneric' and then -- append Generic to the model name, probably _removeIdFromTypeSuffix :: Name -> Type _removeIdFromTypeSuffix oldName@(Name (OccName nm) nameFlavor) = case stripSuffix "Id" (T.pack nm) of Nothing -> ConT oldName Just name -> ConT ''Key `AppT` do ConT $ Name (OccName (T.unpack name)) nameFlavor -- | TODO: if we keep mpsGeneric, let's incorporate this behavior here, so -- end users don't need to import the constructor type as well as the id type -- -- Returns 'Nothing' if the given text does not appear to be a table reference. -- In that case, do the usual thing for generating a type name. -- -- Returns a @Just typ@ if the text appears to be a model name, and if the -- @ModelId@ type is in scope. The 'Type' is a fully qualified reference to -- @'Key' ModelName@ such that end users won't have to import it directly. _lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type) _lookupReferencedTable em fieldTypeText = do let mmodelIdString = do fieldTypeNoId <- stripSuffix "Id" fieldTypeText _ <- M.lookup (EntityNameHS fieldTypeNoId) em pure (T.unpack fieldTypeText) case mmodelIdString of Nothing -> pure Nothing Just modelIdString -> do mIdName <- lookupTypeName modelIdString pure $ fmap _removeIdFromTypeSuffix mIdName _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String _fieldNameEndsWithId ufd = go (unboundFieldType ufd) where go = \case FTTypeCon mmodule name -> do a <- stripSuffix "Id" name pure $ T.unpack $ mconcat [ case mmodule of Nothing -> "" Just m -> mconcat [m, "."] , a , "Id" ] _ -> Nothing backendDataType :: MkPersistSettings -> Type backendDataType mps | mpsGeneric mps = backendT | otherwise = mpsBackend mps -- | TODO: -- -- if we keep mpsGeneric -- then -- let's make this fully qualify the generic name -- else -- let's delete it genericDataType :: MkPersistSettings -> EntityNameHS -> Type -- ^ backend -> Type genericDataType mps name backend | mpsGeneric mps = ConT (mkEntityNameHSGenericName name) `AppT` backend | otherwise = ConT $ mkEntityNameHSName name degen :: [Clause] -> [Clause] degen [] = let err = VarE 'error `AppE` LitE (StringL "Degenerate case, should never happen") in [normalClause [WildP] err] degen x = x -- needs: -- -- * isEntitySum ed -- * field accesor -- * getEntityFields ed -- * used in goSum, or sumConstrName -- * mkEntityDefName ed -- * uses entityHaskell -- * sumConstrName ed fieldDef -- * only needs entity name and field name -- -- data MkToPersistFields = MkToPersistFields -- { isEntitySum :: Bool -- , entityHaskell :: HaskellNameHS -- , entityFieldNames :: [FieldNameHS] -- } mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec mkToPersistFields mps ed = do let isSum = unboundEntitySum ed fields = getUnboundFieldDefs ed clauses <- if isSum then sequence $ zipWith goSum fields [1..] else fmap return go return $ FunD 'toPersistFields clauses where go :: Q Clause go = do xs <- sequence $ replicate fieldCount $ newName "x" let name = mkEntityDefName ed pat = conp name $ fmap VarP xs sp <- [|toPersistValue|] let bod = ListE $ fmap (AppE sp . VarE) xs return $ normalClause [pat] bod fieldCount = length (getUnboundFieldDefs ed) goSum :: UnboundFieldDef -> Int -> Q Clause goSum fieldDef idx = do let name = sumConstrName mps ed fieldDef enull <- [|PersistNull|] let beforeCount = idx - 1 afterCount = fieldCount - idx before = replicate beforeCount enull after = replicate afterCount enull x <- newName "x" sp <- [|toPersistValue|] let body = ListE $ mconcat [ before , [sp `AppE` VarE x] , after ] return $ normalClause [conp name [VarP x]] body mkToFieldNames :: [UniqueDef] -> Q Dec mkToFieldNames pairs = do pairs' <- mapM go pairs return $ FunD 'persistUniqueToFieldNames $ degen pairs' where go (UniqueDef constr _ names _) = do names' <- lift names return $ normalClause [RecP (mkConstraintName constr) []] names' mkUniqueToValues :: [UniqueDef] -> Q Dec mkUniqueToValues pairs = do pairs' <- mapM go pairs return $ FunD 'persistUniqueToValues $ degen pairs' where go :: UniqueDef -> Q Clause go (UniqueDef constr _ names _) = do xs <- mapM (const $ newName "x") names let pat = conp (mkConstraintName constr) $ fmap VarP $ toList xs tpv <- [|toPersistValue|] let bod = ListE $ fmap (AppE tpv . VarE) $ toList xs return $ normalClause [pat] bod isNotNull :: PersistValue -> Bool isNotNull PersistNull = False isNotNull _ = True mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft _ (Right r) = Right r mapLeft f (Left l) = Left (f l) -- needs: -- -- * getEntityFields -- * sumConstrName on field -- * fromValues -- * entityHaskell -- * sumConstrName -- * entityDefConE -- -- mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause] mkFromPersistValues mps entDef | unboundEntitySum entDef = do nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] clauses <- mkClauses [] $ getUnboundFieldDefs entDef return $ clauses `mappend` [normalClause [WildP] nothing] | otherwise = fromValues entDef "fromPersistValues" entE $ fmap unboundFieldNameHS $ filter isHaskellUnboundField $ getUnboundFieldDefs entDef where entName = unEntityNameHS $ getUnboundEntityNameHS entDef mkClauses _ [] = return [] mkClauses before (field:after) = do x <- newName "x" let null' = conp 'PersistNull [] pat = ListP $ mconcat [ fmap (const null') before , [VarP x] , fmap (const null') after ] constr = ConE $ sumConstrName mps entDef field fs <- [|fromPersistValue $(return $ VarE x)|] let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] clauses <- mkClauses (field : before) after return $ clause : clauses entE = entityDefConE entDef type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) fmapE :: Exp fmapE = VarE 'fmap unboundEntitySum :: UnboundEntityDef -> Bool unboundEntitySum = entitySum . unboundEntityDef fieldSel :: Name -> Name -> Exp fieldSel conName fieldName = LamE [RecP conName [(fieldName, VarP xName)]] (VarE xName) where xName = mkName "x" fieldUpd :: Name -- ^ constructor name -> [Name] -- ^ list of field names -> Exp -- ^ record value -> Name -- ^ field name to update -> Exp -- ^ new value -> Exp fieldUpd con names record name new = CaseE record [ Match (RecP con pats) (NormalB body) []] where body = RecConE con [ if k == name then (name, new) else (k, VarE k) | k <- names ] pats = [ (k, VarP k) | k <- names, k /= name] mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause] mkLensClauses mps entDef genDataType = do lens' <- [|lensPTH|] getId <- [|entityKey|] setId <- [|\(Entity _ value) key -> Entity key value|] getVal <- [|entityVal|] dot <- [|(.)|] keyVar <- newName "key" valName <- newName "value" xName <- newName "x" let idClause = normalClause [conp (keyIdName entDef) []] (lens' `AppE` getId `AppE` setId) return $ idClause : if unboundEntitySum entDef then fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef) else zipWith (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames where fieldNames = fieldDefToRecordName mps entDef <$> getUnboundFieldDefs entDef toClause lens' getVal dot keyVar valName xName fieldDef fieldName = normalClause [conp (filterConName mps entDef fieldDef) []] (lens' `AppE` getter `AppE` setter) where defName = mkEntityDefName entDef getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal) setter = LamE [ conp 'Entity [VarP keyVar, VarP valName] , VarP xName ] $ ConE 'Entity `AppE` VarE keyVar `AppE` fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName) toSumClause lens' keyVar valName xName fieldDef = normalClause [conp (filterConName mps entDef fieldDef) []] (lens' `AppE` getter `AppE` setter) where emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) [] getter = LamE [ conp 'Entity [WildP, VarP valName] ] $ CaseE (VarE valName) $ Match (conp (sumConstrName mps entDef fieldDef) [VarP xName]) (NormalB $ VarE xName) [] -- FIXME It would be nice if the types expressed that the Field is -- a sum type and therefore could result in Maybe. : if length (getUnboundFieldDefs entDef) > 1 then [emptyMatch] else [] setter = LamE [ conp 'Entity [VarP keyVar, WildP] , VarP xName ] $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps entDef fieldDef) `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 -> UnboundEntityDef -> Q (Dec, [Dec]) mkKeyTypeDec mps entDef = do (instDecs, i) <- if mpsGeneric mps then if not useNewtype then do pfDec <- pfInstD return (pfDec, supplement [''Generic]) else do gi <- genericNewtypeInstances return (gi, supplement []) else if not useNewtype then do pfDec <- pfInstD return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic]) else do let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON] if customKeyType then return ([], allInstances) else do bi <- backendKeyI return (bi, allInstances) requirePersistentExtensions -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1" -- This is much better for debugging/logging purposes -- cf. https://github.com/yesodweb/persistent/issues/1104 let alwaysStockStrategyTypeclasses = [''Show, ''Read] deriveClauses = fmap (\typeclass -> if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses) then DerivClause (Just StockStrategy) [(ConT typeclass)] else DerivClause (Just NewtypeStrategy) [(ConT typeclass)] ) i #if MIN_VERSION_template_haskell(2,15,0) let kd = if useNewtype then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses #else let kd = if useNewtype then NewtypeInstD [] k [recordType] Nothing dec deriveClauses else DataInstD [] k [recordType] Nothing [dec] deriveClauses #endif return (kd, instDecs) where keyConE = keyConExp entDef unKeyE = unKeyExp entDef dec = RecC (keyConName entDef) (toList $ keyFields mps entDef) k = ''Key recordType = genericDataType mps (getUnboundEntityNameHS entDef) backendT pfInstD = -- FIXME: generate a PersistMap instead of PersistList [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 instance PersistFieldSql (Key $(pure recordType)) where sqlType _ = SqlString instance ToJSON (Key $(pure recordType)) instance FromJSON (Key $(pure recordType)) |] backendKeyGenericI = [d| instance PersistStore $(pure backendT) => ToBackendKey $(pure backendT) $(pure recordType) where toBackendKey = $(return unKeyE) fromBackendKey = $(return keyConE) |] backendKeyI = let bdt = backendDataType mps in [d| instance ToBackendKey $(pure bdt) $(pure recordType) where toBackendKey = $(return unKeyE) fromBackendKey = $(return keyConE) |] genericNewtypeInstances = do requirePersistentExtensions alwaysInstances <- -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here [d|deriving stock instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) deriving stock 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)) |] mappend alwaysInstances <$> if customKeyType then pure [] else backendKeyGenericI useNewtype = pkNewtype mps entDef customKeyType = or [ not (defaultIdType entDef) , not useNewtype , isJust (entityPrimary (unboundEntityDef entDef)) , not isBackendKey ] isBackendKey = case getImplicitIdType mps of ConT bk `AppT` _ | bk == ''BackendKey -> True _ -> False supplement :: [Name] -> [Name] supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) -- | Returns 'True' if the key definition has less than 2 fields. -- -- @since 2.11.0.0 pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool pkNewtype mps entDef = length (keyFields mps entDef) < 2 -- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the -- QuasiQuoter produces for an implicit ID and defaultIdType :: UnboundEntityDef -> Bool defaultIdType entDef = case unboundPrimarySpec entDef of DefaultKey _ -> True _ -> False keyFields :: MkPersistSettings -> UnboundEntityDef -> NonEmpty (Name, Strict, Type) keyFields mps entDef = case unboundPrimarySpec entDef of NaturalKey ucd -> fmap naturalKeyVar (unboundCompositeCols ucd) DefaultKey _ -> pure . idKeyVar $ getImplicitIdType mps SurrogateKey k -> pure . idKeyVar $ case unboundIdType k of Nothing -> getImplicitIdType mps Just ty -> ftToType ty where unboundFieldDefs = getUnboundFieldDefs entDef naturalKeyVar fieldName = case findField fieldName unboundFieldDefs of Nothing -> error "column not defined on entity" Just unboundFieldDef -> ( keyFieldName mps entDef (unboundFieldNameHS unboundFieldDef) , notStrict , ftToType $ unboundFieldType unboundFieldDef ) idKeyVar ft = ( unKeyName entDef , notStrict , ft ) findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef findField fieldName = List.find ((fieldName ==) . unboundFieldNameHS) mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec mkKeyToValues mps entDef = do recordName <- newName "record" FunD 'keyToValues . pure <$> case unboundPrimarySpec entDef of NaturalKey ucd -> do normalClause [VarP recordName] <$> toValuesPrimary recordName ucd _ -> do normalClause [] <$> [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|] where toValuesPrimary recName ucd = ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd) f recName fieldNameHS = [| toPersistValue ($(varE $ keyFieldName mps entDef fieldNameHS) $(varE recName)) |] normalClause :: [Pat] -> Exp -> Clause normalClause p e = Clause p (NormalB e) [] -- needs: -- -- * entityPrimary -- * keyConExp entDef mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec mkKeyFromValues _mps entDef = FunD 'keyFromValues <$> case unboundPrimarySpec entDef of NaturalKey ucd -> fromValues entDef "keyFromValues" keyConE (toList $ unboundCompositeCols ucd) _ -> do e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] return [normalClause [] e] where keyConE = keyConExp entDef headNote :: [PersistValue] -> PersistValue headNote = \case [x] -> x xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs -- needs from entity: -- -- * entityText entDef -- * entityHaskell -- * entityDB entDef -- -- needs from fields: -- -- * mkPersistValue -- * fieldHaskell -- -- data MkFromValues = MkFromValues -- { entityHaskell :: EntityNameHS -- , entityDB :: EntitynameDB -- , entityFieldNames :: [FieldNameHS] -- } fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause] fromValues entDef funName constructExpr fields = do x <- newName "x" let funMsg = mconcat [ entityText entDef , ": " , funName , " failed on: " ] patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|] suc <- patternSuccess return [ suc, normalClause [VarP x] patternMatchFailure ] where tableName = unEntityNameDB (entityDB (unboundEntityDef entDef)) patternSuccess = case fields of [] -> do rightE <- [|Right|] return $ normalClause [ListP []] (rightE `AppE` constructExpr) _ -> 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 constructExpr x1 applyE <- [|(<*>)|] let applyFromPersistValue = infixFromPersistValue applyE return $ normalClause [ListP $ fmap 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) mkPersistValue field = let fieldName = unFieldNameHS field in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|] -- | Render an error message based on the @tableName@ and @fieldName@ with -- the provided message. -- -- @since 2.8.2 fieldError :: Text -> Text -> Text -> Text fieldError tableName fieldName err = mconcat [ "Couldn't parse field `" , fieldName , "` from table `" , tableName , "`. " , err ] mkEntity :: M.Map EntityNameHS a -> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec] mkEntity embedEntityMap entityMap mps preDef = do when (isEntitySum (unboundEntityDef preDef)) $ do reportWarning $ unlines [ "persistent has deprecated sum type entities as of 2.14.0.0." , "We will delete support for these entities in 2.15.0.0." , "If you need these, please add a comment on this GitHub issue:" , "" , " https://github.com/yesodweb/persistent/issues/987" ] entityDefExp <- liftAndFixKeys mps embedEntityMap entityMap preDef let entDef = fixEntityDef preDef fields <- mkFields mps entityMap entDef let name = mkEntityDefName entDef let clazz = ConT ''PersistEntity `AppT` genDataType tpf <- mkToPersistFields mps entDef fpv <- mkFromPersistValues mps entDef utv <- mkUniqueToValues $ entityUniques $ unboundEntityDef entDef puk <- mkUniqueKeys entDef fkc <- mapM (mkForeignKeysComposite mps entDef) $ unboundForeignDefs entDef toFieldNames <- mkToFieldNames $ entityUniques $ unboundEntityDef entDef (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef keyToValues' <- mkKeyToValues mps entDef keyFromValues' <- mkKeyFromValues mps entDef let addSyn -- FIXME maybe remove this | mpsGeneric mps = (:) $ TySynD name [] $ genericDataType mps entName $ mpsBackend mps | otherwise = id lensClauses <- mkLensClauses mps entDef genDataType lenses <- mkLenses mps entityMap entDef let instanceConstraint = if not (mpsGeneric mps) then [] else [mkClassP ''PersistStore [backendT]] [keyFromRecordM'] <- case unboundPrimarySpec entDef of NaturalKey ucd -> do recordName <- newName "record" let keyCon = keyConName entDef keyFields' = fieldNameToRecordName mps entDef <$> unboundCompositeCols ucd constr = foldl' AppE (ConE keyCon) (toList $ fmap (\n -> VarE n `AppE` VarE recordName ) keyFields' ) keyFromRec = varP 'keyFromRecordM [d| $(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr)) |] _ -> [d|$(varP 'keyFromRecordM) = Nothing|] dtd <- dataTypeDec mps entityMap entDef let allEntDefs = entityFieldTHCon <$> efthAllFields fields allEntDefClauses = entityFieldTHClause <$> efthAllFields fields mkTabulateA <- do fromFieldName <- newName "fromField" let names'types = filter (\(n, _) -> n /= mkName "Id") $ map (getConNameAndType . entityFieldTHCon) $ entityFieldsTHFields fields getConNameAndType = \case ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name []) -> (name, fieldTy) other -> error $ mconcat [ "persistent internal error: field constructor did not have xpected shape. \n" , "Expected: \n" , " ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n" , "Got: \n" , " " <> show other ] mkEntityVal = List.foldl' (\acc (n, _) -> InfixE (Just acc) (VarE '(<*>)) (Just (VarE fromFieldName `AppE` ConE n)) ) (VarE 'pure `AppE` ConE (mkEntityNameHSName entName)) names'types primaryKeyField = fst $ getConNameAndType $ entityFieldTHCon $ entityFieldsTHPrimary fields body <- if isEntitySum $ unboundEntityDef entDef then [| error "tabulateEntityA does not make sense for sum type" |] else [| Entity <$> $(varE fromFieldName) $(conE primaryKeyField) <*> $(pure mkEntityVal) |] pure $ FunD 'tabulateEntityA [ Clause [VarP fromFieldName] (NormalB body) [] ] return $ addSyn $ dtd : mconcat fkc `mappend` ( [ TySynD (keyIdName entDef) [] $ ConT ''Key `AppT` ConT name , instanceD instanceConstraint clazz [ uniqueTypeDec mps entityMap entDef , keyTypeDec , keyToValues' , keyFromValues' , keyFromRecordM' , mkTabulateA , FunD 'entityDef [normalClause [WildP] entityDefExp] , tpf , FunD 'fromPersistValues fpv , toFieldNames , utv , puk #if MIN_VERSION_template_haskell(2,15,0) , DataInstD [] Nothing (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) Nothing allEntDefs [] #else , DataInstD [] ''EntityField [ genDataType , VarT $ mkName "typ" ] Nothing allEntDefs [] #endif , FunD 'persistFieldDef allEntDefClauses #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 entDef)] , FunD 'fieldLens lensClauses ] ] `mappend` lenses) `mappend` keyInstanceDecs where genDataType = genericDataType mps entName backendT entName = getUnboundEntityNameHS preDef data EntityFieldsTH = EntityFieldsTH { entityFieldsTHPrimary :: EntityFieldTH , entityFieldsTHFields :: [EntityFieldTH] } efthAllFields :: EntityFieldsTH -> [EntityFieldTH] efthAllFields EntityFieldsTH{..} = stripIdFieldDef entityFieldsTHPrimary : entityFieldsTHFields stripIdFieldDef :: EntityFieldTH -> EntityFieldTH stripIdFieldDef efth = efth { entityFieldTHClause = go (entityFieldTHClause efth) } where go (Clause ps bdy ds) = Clause ps bdy' ds where bdy' = case bdy of NormalB e -> NormalB $ AppE (VarE 'stripIdFieldImpl) e _ -> bdy -- | @persistent@ used to assume that an Id was always a single field. -- -- This method preserves as much backwards compatibility as possible. stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef stripIdFieldImpl eid = case eid of EntityIdField fd -> fd EntityIdNaturalKey cd -> case compositeFields cd of (x :| xs) -> case xs of [] -> x _ -> dummyFieldDef where dummyFieldDef = FieldDef { fieldHaskell = FieldNameHS "Id" , fieldDB = FieldNameDB "__composite_key_no_id__" , fieldType = FTTypeCon Nothing "__Composite_Key__" , fieldSqlType = SqlOther "Composite Key" , fieldAttrs = [] , fieldStrict = False , fieldReference = NoReference , fieldCascade = noCascade , fieldComments = Nothing , fieldGenerated = Nothing , fieldIsImplicitIdColumn = False } mkFields :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH mkFields mps entityMap entDef = EntityFieldsTH <$> mkIdField mps entDef <*> mapM (mkField mps entityMap entDef) (getUnboundFieldDefs entDef) mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] mkUniqueKeyInstances mps entDef = do requirePersistentExtensions case entityUniques (unboundEntityDef entDef) of [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey where requireUniquesPName = 'requireUniquesP onlyUniquePName = 'onlyUniqueP typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx withPersistStoreWriteCxt = if mpsGeneric mps then do write <- [t|PersistStoreWrite $(pure backendT) |] 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 '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| head . persistUniqueKeys|] 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| NEL.fromList . persistUniqueKeys|] let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] cxt <- withPersistStoreWriteCxt pure [instanceD cxt atLeastOneUniqueKeyClass impl] genDataType = genericDataType mps (getUnboundEntityNameHS entDef) backendT entityText :: UnboundEntityDef -> Text entityText = unEntityNameHS . getUnboundEntityNameHS mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] mkLenses mps _ _ | not (mpsGenerateLenses mps) = return [] mkLenses _ _ ent | entitySum (unboundEntityDef ent) = return [] mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` fieldNames) $ \(field, fieldName) -> do let lensName = mkEntityLensName mps ent field needleN <- newName "needle" setterN <- newName "setter" fN <- newName "f" aN <- newName "a" yN <- newName "y" let needle = VarE needleN setter = VarE setterN f = VarE fN a = VarE aN y = VarE yN fT = mkName "f" -- FIXME if we want to get really fancy, then: if this field is the -- *only* Id field present, then set backend1 and backend2 to different -- values backend1 = backendName backend2 = backendName aT = maybeIdType mps entityMap field (Just backend1) Nothing bT = maybeIdType mps entityMap field (Just backend2) Nothing mkST backend = genericDataType mps (getUnboundEntityNameHS ent) (VarT backend) sT = mkST backend1 tT = mkST backend2 t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 vars = mkForallTV fT : (if mpsGeneric mps then [mkForallTV backend1{-, PlainTV backend2-}] else []) return [ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $ (aT `arrow` (VarT fT `AppT` bT)) `arrow` (sT `arrow` (VarT fT `AppT` tT)) , FunD lensName $ return $ Clause [VarP fN, VarP aN] (NormalB $ fmapE `AppE` setter `AppE` (f `AppE` needle)) [ FunD needleN [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)] , FunD setterN $ return $ normalClause [VarP yN] (fieldUpd (mkEntityDefName ent) fieldNames a fieldName y) ] ] where fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent #if MIN_VERSION_template_haskell(2,17,0) mkPlainTV :: Name -> TyVarBndr () mkPlainTV n = PlainTV n () mkDoE :: [Stmt] -> Exp mkDoE stmts = DoE Nothing stmts mkForallTV :: Name -> TyVarBndr Specificity mkForallTV n = PlainTV n SpecifiedSpec #else mkDoE :: [Stmt] -> Exp mkDoE = DoE mkPlainTV :: Name -> TyVarBndr mkPlainTV = PlainTV mkForallTV :: Name -> TyVarBndr mkForallTV = mkPlainTV #endif mkForeignKeysComposite :: MkPersistSettings -> UnboundEntityDef -> UnboundForeignDef -> Q [Dec] mkForeignKeysComposite mps entDef foreignDef | foreignToPrimary (unboundForeignDef foreignDef) = do let fieldName = fieldNameToRecordName mps entDef fname = fieldName $ constraintToField $ foreignConstraintNameHaskell $ unboundForeignDef foreignDef reftableString = unpack $ unEntityNameHS $ foreignRefTableHaskell $ unboundForeignDef foreignDef reftableKeyName = mkName $ reftableString `mappend` "Key" tablename = mkEntityDefName entDef fieldStore = mkFieldStore entDef recordName <- newName "record_mkForeignKeysComposite" let mkFldE foreignName = -- using coerce here to convince SqlBackendKey to go away VarE 'coerce `AppE` (VarE (fieldName foreignName) `AppE` VarE recordName) mkFldR ffr = let e = mkFldE (ffrSourceField ffr) in case ffrTargetField ffr of FieldNameHS "Id" -> VarE 'toBackendKey `AppE` e _ -> e foreignFieldNames foreignFieldList = case foreignFieldList of FieldListImpliedId names -> names FieldListHasReferences refs -> fmap ffrSourceField refs fldsE = getForeignNames $ (unboundForeignFields foreignDef) getForeignNames = \case FieldListImpliedId xs -> fmap mkFldE xs FieldListHasReferences xs -> fmap mkFldR xs nullErr n = error $ "Could not find field definition for: " <> show n fNullable = setNull $ fmap (\n -> fromMaybe (nullErr n) $ getFieldDef n fieldStore) $ foreignFieldNames $ unboundForeignFields foreignDef mkKeyE = foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE fn = FunD fname [normalClause [VarP recordName] mkKeyE] keyTargetTable = maybeTyp fNullable $ ConT ''Key `AppT` ConT (mkName reftableString) sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |] pure [ SigD fname sigTy , fn ] | otherwise = pure [] where constraintToField = FieldNameHS . unConstraintNameHS maybeExp :: Bool -> Exp -> Exp maybeExp may exp | may = fmapE `AppE` exp | otherwise = exp maybeTyp :: Bool -> Type -> Type maybeTyp may typ | may = ConT ''Maybe `AppT` typ | otherwise = typ entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues where columnNames = fmap (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity))) fieldsAsPersistValues = fmap 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 $ fmap lookupPersistValueByColumnName columnNames -- | Produce code similar to the following: -- -- @ -- instance PersistEntity e => PersistField e where -- toPersistValue = entityToPersistValueHelper -- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"] -- sqlType _ = SqlString -- @ persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] persistFieldFromEntity mps entDef = do sqlStringConstructor' <- [|SqlString|] toPersistValueImplementation <- [|entityToPersistValueHelper|] fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|] return [ persistFieldInstanceD (mpsGeneric mps) typ [ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ] , FunD 'fromPersistValue [ normalClause [] fromPersistValueImplementation ] ] , persistFieldSqlInstanceD (mpsGeneric mps) typ [ sqlTypeFunD sqlStringConstructor' ] ] where typ = genericDataType mps (entityHaskell (unboundEntityDef entDef)) backendT entFields = filter isHaskellUnboundField $ getUnboundFieldDefs entDef columnNames = fmap (unpack . unFieldNameHS . unboundFieldNameHS) entFields -- | Apply the given list of functions to the same @EntityDef@s. -- -- This function is useful for cases such as: -- -- >>> share [mkEntityDefList "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec] share fs x = mconcat <$> mapM ($ x) fs -- | Creates a declaration for the @['EntityDef']@ from the @persistent@ -- schema. This is necessary because the Persistent QuasiQuoter is unable -- to know the correct type of ID fields, and assumes that they are all -- Int64. -- -- Provide this in the list you give to 'share', much like @'mkMigrate'@. -- -- @ -- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...] -- @ -- -- @since 2.7.1 mkEntityDefList :: String -- ^ The name that will be given to the 'EntityDef' list. -> [UnboundEntityDef] -> Q [Dec] mkEntityDefList entityList entityDefs = do let entityListName = mkName entityList edefs <- fmap ListE . forM entityDefs $ \entDef -> let entityType = entityDefConT entDef in [|entityDef (Proxy :: Proxy $(entityType))|] typ <- [t|[EntityDef]|] pure [ SigD entityListName typ , ValD (VarP entityListName) (NormalB edefs) [] ] mkUniqueKeys :: UnboundEntityDef -> Q Dec mkUniqueKeys def | entitySum (unboundEntityDef def) = return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])] mkUniqueKeys def = do c <- clause return $ FunD 'persistUniqueKeys [c] where clause = do xs <- forM (getUnboundFieldDefs def) $ \fieldDef -> do let x = unboundFieldNameHS fieldDef x' <- newName $ '_' : unpack (unFieldNameHS x) return (x, x') let pcs = fmap (go xs) $ entityUniques $ unboundEntityDef def let pat = conp (mkEntityDefName def) (fmap (VarP . snd) xs) return $ normalClause [pat] (ListE pcs) go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp go xs (UniqueDef name _ cols _) = foldl' (go' xs) (ConE (mkConstraintName name)) (toList $ fmap fst cols) go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp go' xs front col = let Just col' = lookup col xs in front `AppE` VarE col' sqlTypeFunD :: Exp -> Dec sqlTypeFunD st = FunD 'sqlType [ normalClause [WildP] st ] typeInstanceD :: Name -> Bool -- ^ include PersistStore backend constraint -> Type -> [Dec] -> Dec typeInstanceD clazz hasBackend typ = instanceD ctx (ConT clazz `AppT` typ) where ctx | hasBackend = [mkClassP ''PersistStore [backendT]] | otherwise = [] persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint -> Type -> [Dec] -> Dec persistFieldInstanceD = typeInstanceD ''PersistField persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint -> Type -> [Dec] -> Dec persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql -- | Automatically creates a valid 'PersistField' instance for any datatype -- that has valid 'Show' and 'Read' instances. Can be very convenient for -- 'Enum' types. derivePersistField :: String -> Q [Dec] derivePersistField s = do ss <- [|SqlString|] tpv <- [|PersistText . pack . show|] fpv <- [|\dt v -> case fromPersistValue v of Left e -> Left e Right s' -> case reads $ unpack s' of (x, _):_ -> Right x [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|] return [ persistFieldInstanceD False (ConT $ mkName s) [ FunD 'toPersistValue [ normalClause [] tpv ] , FunD 'fromPersistValue [ normalClause [] (fpv `AppE` LitE (StringL s)) ] ] , persistFieldSqlInstanceD False (ConT $ mkName s) [ sqlTypeFunD ss ] ] -- | Automatically creates a valid 'PersistField' instance for any datatype -- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it -- generates instances similar to these: -- -- @ -- instance PersistField T where -- toPersistValue = PersistByteString . L.toStrict . encode -- fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue -- instance PersistFieldSql T where -- sqlType _ = SqlString -- @ derivePersistFieldJSON :: String -> Q [Dec] derivePersistFieldJSON s = do ss <- [|SqlString|] tpv <- [|PersistText . toJsonText|] fpv <- [|\dt v -> do text <- fromPersistValue v let bs' = TE.encodeUtf8 text case eitherDecodeStrict' bs' of Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs' Right x -> Right x|] return [ persistFieldInstanceD False (ConT $ mkName s) [ FunD 'toPersistValue [ normalClause [] tpv ] , FunD 'fromPersistValue [ normalClause [] (fpv `AppE` LitE (StringL s)) ] ] , persistFieldSqlInstanceD False (ConT $ mkName s) [ sqlTypeFunD ss ] ] -- | The basic function for migrating models, no Template Haskell required. -- -- It's probably best to use this in concert with 'mkEntityDefList', and then -- call 'migrateModels' with the result from that function. -- -- @ -- share [mkPersist sqlSettings, mkEntityDefList "entities"] [persistLowerCase| ... |] -- -- migrateAll = 'migrateModels' entities -- @ -- -- The function 'mkMigrate' currently implements exactly this behavior now. If -- you're splitting up the entity definitions into separate files, then it is -- better to use the entity definition list and the concatenate all the models -- together into a big list to call with 'migrateModels'. -- -- @ -- module Foo where -- -- share [mkPersist s, mkEntityDefList "fooModels"] ... -- -- -- module Bar where -- -- share [mkPersist s, mkEntityDefList "barModels"] ... -- -- module Migration where -- -- import Foo -- import Bar -- -- migrateAll = migrateModels (fooModels <> barModels) -- @ -- -- @since 2.13.0.0 migrateModels :: [EntityDef] -> Migration migrateModels defs= forM_ (filter isMigrated defs) $ \def -> migrate defs def where isMigrated def = pack "no-migrate" `notElem` entityAttrs def -- | Creates a single function to perform all migrations for the entities -- defined here. One thing to be aware of is dependencies: if you have entities -- with foreign references, make sure to place those definitions after the -- entities they reference. -- -- In @persistent-2.13.0.0@, this was changed to *ignore* the input entity def -- list, and instead defer to 'mkEntityDefList' to get the correct entities. -- This avoids problems where the QuasiQuoter is unable to know what the right -- reference types are. This sets 'mkPersist' to be the "single source of truth" -- for entity definitions. mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec] mkMigrate fun eds = do let entityDefListName = ("entityDefListFor" <> fun) body <- [| migrateModels $(varE (mkName entityDefListName)) |] edList <- mkEntityDefList entityDefListName eds pure $ edList <> [ SigD (mkName fun) (ConT ''Migration) , FunD (mkName fun) [normalClause [] body] ] data EntityFieldTH = EntityFieldTH { entityFieldTHCon :: Con , entityFieldTHClause :: Clause } -- Ent -- fieldName FieldType -- -- forall . typ ~ FieldType => EntFieldName -- -- EntFieldName = FieldDef .... -- -- Field Def Accessors Required: mkField :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UnboundFieldDef -> Q EntityFieldTH mkField mps entityMap et fieldDef = do let con = ForallC [] [mkEqualP (VarT $ mkName "typ") fieldT] $ NormalC name [] fieldT = maybeIdType mps entityMap fieldDef Nothing Nothing bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef) let cla = normalClause [conp name []] bod return $ EntityFieldTH con cla where name = filterConName mps et fieldDef mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH mkIdField mps ued = do let entityName = getUnboundEntityNameHS ued entityIdType | mpsGeneric mps = ConT ''Key `AppT` ( ConT (mkEntityNameHSGenericName entityName) `AppT` backendT ) | otherwise = ConT $ mkName $ (T.unpack $ unEntityNameHS entityName) ++ "Id" name = filterConName' mps entityName (FieldNameHS "Id") clause <- fixPrimarySpec mps ued pure EntityFieldTH { entityFieldTHCon = ForallC [] [mkEqualP (VarT $ mkName "typ") entityIdType] $ NormalC name [] , entityFieldTHClause = normalClause [conp name []] clause } lookupEntityField :: PersistEntity entity => Proxy entity -> FieldNameHS -> FieldDef lookupEntityField prxy fieldNameHS = fromMaybe boom $ List.find ((fieldNameHS ==) . fieldHaskell) $ entityFields $ entityDef prxy where boom = error "Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name" mkLookupEntityField :: UnboundEntityDef -> FieldNameHS -> Q Exp mkLookupEntityField ued ufd = [| lookupEntityField (Proxy :: Proxy $(conT entityName)) $(lift ufd) |] where entityName = mkEntityNameHSName (getUnboundEntityNameHS ued) maybeNullable :: UnboundFieldDef -> Bool maybeNullable fd = isUnboundFieldNullable fd == Nullable ByMaybeAttr ftToType :: FieldType -> Type ftToType = \case FTTypeCon Nothing t -> ConT $ mkName $ T.unpack t -- This type is generated from the Quasi-Quoter. -- Adding this special case avoids users needing to import Data.Int FTTypeCon (Just "Data.Int") "Int64" -> ConT ''Int64 FTTypeCon (Just m) t -> ConT $ mkName $ unpack $ concat [m, ".", t] FTLit l -> LitT (typeLitToTyLit l) FTTypePromoted t -> PromotedT $ mkName $ T.unpack t FTApp x y -> ftToType x `AppT` ftToType y FTList x -> ListT `AppT` ftToType x typeLitToTyLit :: FieldTypeLit -> TyLit typeLitToTyLit = \case IntTypeLit n -> NumTyLit n TextTypeLit t -> StrTyLit (T.unpack t) infixr 5 ++ (++) :: Monoid m => m -> m -> m (++) = mappend mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] mkJSON _ def | ("json" `notElem` entityAttrs (unboundEntityDef def)) = return [] mkJSON mps (fixEntityDef -> def) = do requireExtensions [[FlexibleInstances]] pureE <- [|pure|] apE' <- [|(<*>)|] let objectE = VarE 'object withObjectE = VarE 'withObject dotEqualE = VarE '(.=) dotColonE = VarE '(.:) dotColonQE = VarE '(.:?) #if MIN_VERSION_aeson(2,0,0) toKeyE = VarE 'Key.fromString #else toKeyE = VarE 'pack #endif obj <- newName "obj" let fields = getUnboundFieldDefs def xs <- mapM fieldToJSONValName fields let conName = mkEntityDefName def typ = genericDataType mps (entityHaskell (unboundEntityDef def)) backendT toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] where toJSON' = FunD 'toJSON $ return $ normalClause [conp conName $ fmap VarP xs] (objectE `AppE` ListE pairs) where pairs = zipWith toPair fields xs toPair f x = InfixE (Just (toKeyE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f))) dotEqualE (Just $ VarE x) fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] where entNameStrLit = StringL $ T.unpack (unEntityNameHS (getUnboundEntityNameHS def)) parseJSONBody = withObjectE `AppE` LitE entNameStrLit `AppE` decoderImpl parseJSON' = FunD 'parseJSON [ normalClause [] parseJSONBody ] decoderImpl = LamE [VarP obj] (foldl' (\x y -> InfixE (Just x) apE' (Just y)) (pureE `AppE` ConE conName) pulls ) where pulls = fmap toPull fields toPull f = InfixE (Just $ VarE obj) (if maybeNullable f then dotColonQE else dotColonE) (Just $ AppE toKeyE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f) case mpsEntityJSON mps of Nothing -> return [toJSONI, fromJSONI] Just entityJSON -> do entityJSONIs <- if mpsGeneric mps then [d| 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)) |] else [d| instance ToJSON (Entity $(pure typ)) where toJSON = $(varE (entityToJSON entityJSON)) instance FromJSON (Entity $(pure typ)) where parseJSON = $(varE (entityFromJSON entityJSON)) |] return $ toJSONI : fromJSONI : entityJSONIs mkClassP :: Name -> [Type] -> Pred mkClassP cla tys = foldl AppT (ConT cla) tys mkEqualP :: Type -> Type -> Pred mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright] notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness isStrict :: Bang isStrict = Bang NoSourceUnpackedness SourceStrict instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing -- | 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 = requireExtensions requiredExtensions where requiredExtensions = fmap pure [ DerivingStrategies , GeneralizedNewtypeDeriving , StandaloneDeriving , UndecidableInstances , MultiParamTypeClasses ] mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do let entityHaskellName = getEntityHaskellName $ unboundEntityDef ed allFields = getUnboundFieldDefs ed mkEntityFieldConstr fieldHaskellName = conE $ filterConName' mps entityHaskellName fieldHaskellName :: Q Exp regularFields <- forM (toList allFields) $ \fieldDef -> do let fieldHaskellName = unboundFieldNameHS fieldDef let fieldNameT :: Q Type fieldNameT = litT $ strTyLit $ T.unpack $ lowerFirstIfId $ unFieldNameHS fieldHaskellName lowerFirstIfId "Id" = "id" lowerFirstIfId xs = xs fieldTypeT | fieldHaskellName == FieldNameHS "Id" = conT ''Key `appT` recordNameT | otherwise = pure $ maybeIdType mps entityMap fieldDef Nothing Nothing entityFieldConstr = mkEntityFieldConstr fieldHaskellName mkInstance fieldNameT fieldTypeT entityFieldConstr mkey <- case unboundPrimarySpec ed of NaturalKey _ -> pure [] _ -> do let fieldHaskellName = FieldNameHS "Id" entityFieldConstr = mkEntityFieldConstr fieldHaskellName fieldTypeT = conT ''Key `appT` recordNameT mkInstance [t|"id"|] fieldTypeT entityFieldConstr pure (mkey <> join regularFields) where nameG = mkEntityDefGenericName ed recordNameT | mpsGeneric mps = conT nameG `appT` varT backendName | otherwise = entityDefConT ed mkInstance fieldNameT fieldTypeT entityFieldConstr = [d| instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where symbolToField = $(entityFieldConstr) |] -- | Pass in a list of lists of extensions, where any of the given -- extensions will satisfy it. For example, you might need either GADTs or -- ExistentialQuantification, so you'd write: -- -- > requireExtensions [[GADTs, ExistentialQuantification]] -- -- But if you need TypeFamilies and MultiParamTypeClasses, then you'd -- write: -- -- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]] requireExtensions :: [[Extension]] -> Q () requireExtensions requiredExtensions = 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 . or) . traverse isExtEnabled) requiredExtensions case mapMaybe listToMaybe 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" (fmap show extensions) , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" , List.intercalate "\n" (fmap extensionToPragma extensions) ] where extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" -- | creates a TH Name for use in the ToJSON instance fieldToJSONValName :: UnboundFieldDef -> Q Name fieldToJSONValName = newName . T.unpack . unFieldNameHSForJSON . unboundFieldNameHS -- | This special-cases "type_" and strips out its underscore. When -- used for JSON serialization and deserialization, it works around -- unFieldNameHSForJSON :: FieldNameHS -> Text unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS where fixTypeUnderscore = \case "type" -> "type_" name -> name entityDefConK :: UnboundEntityDef -> Kind entityDefConK = conK . mkEntityDefName entityDefConT :: UnboundEntityDef -> Q Type entityDefConT = pure . entityDefConK entityDefConE :: UnboundEntityDef -> Exp entityDefConE = ConE . mkEntityDefName -- | creates a TH Name for an entity's field, based on the entity -- name and the field name, so for example: -- -- Customer -- name Text -- -- This would generate `customerName` as a TH Name fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name fieldNameToRecordName mps entDef fieldName = mkRecordName mps mUnderscore (entityHaskell (unboundEntityDef entDef)) fieldName where mUnderscore | mpsGenerateLenses mps = Just "_" | otherwise = Nothing -- | as above, only takes a `FieldDef` fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (unboundFieldNameHS fieldDef) -- | creates a TH Name for a lens on an entity's field, based on the entity -- name and the field name, so as above but for the Lens -- -- Customer -- name Text -- -- Generates a lens `customerName` when `mpsGenerateLenses` is true -- while `fieldNameToRecordName` generates a prefixed function -- `_customerName` mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name mkEntityLensName mps entDef fieldDef = mkRecordName mps Nothing (entityHaskell (unboundEntityDef entDef)) (unboundFieldNameHS fieldDef) mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name mkRecordName mps prefix entNameHS fieldNameHS = mkName $ T.unpack $ fromMaybe "" prefix <> lowerFirst recName where recName :: Text recName | mpsPrefixFields mps = mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText) | otherwise = fieldNameText entityNameText :: Text entityNameText = unEntityNameHS entNameHS fieldNameText :: Text fieldNameText = unFieldNameHS fieldNameHS -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name] mkEntityDefDeriveNames mps entDef = let entityInstances = mkName . T.unpack <$> entityDerives (unboundEntityDef entDef) additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps in entityInstances <> additionalInstances -- | Make a TH Name for the EntityDef's Haskell type mkEntityNameHSName :: EntityNameHS -> Name mkEntityNameHSName = mkName . T.unpack . unEntityNameHS -- | As above only taking an `EntityDef` mkEntityDefName :: UnboundEntityDef -> Name mkEntityDefName = mkEntityNameHSName . entityHaskell . unboundEntityDef -- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric mkEntityDefGenericName :: UnboundEntityDef -> Name mkEntityDefGenericName = mkEntityNameHSGenericName . entityHaskell . unboundEntityDef mkEntityNameHSGenericName :: EntityNameHS -> Name mkEntityNameHSGenericName name = mkName $ T.unpack (unEntityNameHS name <> "Generic") -- needs: -- -- * entityHaskell -- * field on EntityDef -- * fieldHaskell -- * field on FieldDef -- sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name sumConstrName mps entDef unboundFieldDef = mkName $ T.unpack name where name | mpsPrefixFields mps = modifiedName ++ "Sum" | otherwise = fieldName ++ "Sum" fieldNameHS = unboundFieldNameHS unboundFieldDef modifiedName = mpsConstraintLabelModifier mps entityName fieldName entityName = unEntityNameHS $ getUnboundEntityNameHS entDef fieldName = upperFirst $ unFieldNameHS fieldNameHS -- | Turn a ConstraintName into a TH Name mkConstraintName :: ConstraintNameHS -> Name mkConstraintName (ConstraintNameHS name) = mkName (T.unpack name) keyIdName :: UnboundEntityDef -> Name keyIdName = mkName . T.unpack . keyIdText keyIdText :: UnboundEntityDef -> Text keyIdText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) `mappend` "Id" unKeyName :: UnboundEntityDef -> Name unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef unKeyExp :: UnboundEntityDef -> Exp unKeyExp ent = fieldSel (keyConName ent) (unKeyName ent) backendT :: Type backendT = VarT backendName backendName :: Name backendName = mkName "backend" -- needs: -- -- * keyText -- * entityNameHaskell -- * fields -- * fieldHaskell -- -- keyConName :: EntityNameHS -> [FieldHaskell] -> Name keyConName :: UnboundEntityDef -> Name keyConName entDef = keyConName' (getUnboundEntityNameHS entDef) (unboundFieldNameHS <$> unboundEntityFields (entDef)) keyConName' :: EntityNameHS -> [FieldNameHS] -> Name keyConName' entName entFields = mkName $ T.unpack $ resolveConflict $ keyText' entName where resolveConflict kn = if conflict then kn `mappend` "'" else kn conflict = any (== FieldNameHS "key") entFields -- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp keyConExp :: UnboundEntityDef -> Exp keyConExp ed = ConE $ keyConName ed keyText :: UnboundEntityDef -> Text keyText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) ++ "Key" keyText' :: EntityNameHS -> Text keyText' entName = unEntityNameHS entName ++ "Key" keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name keyFieldName mps entDef fieldDef | pkNewtype mps entDef = unKeyName entDef | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS fieldDef filterConName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name filterConName mps (unboundEntityDef -> entity) field = filterConName' mps (entityHaskell entity) (unboundFieldNameHS field) filterConName' :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name filterConName' mps entity field = mkName $ T.unpack name where name | field == FieldNameHS "Id" = entityName ++ fieldName | mpsPrefixFields mps = modifiedName | otherwise = fieldName modifiedName = mpsConstraintLabelModifier mps entityName fieldName entityName = unEntityNameHS entity fieldName = upperFirst $ unFieldNameHS field -- | Splice in a list of all 'EntityDef' in scope. This is useful when running -- 'mkPersist' to ensure that all entity definitions are available for setting -- foreign keys, and for performing migrations with all entities available. -- -- 'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to -- account for entities defined elsewhere, you'll @mappend $(discoverEntities)@. -- -- For example, -- -- @ -- share -- [ mkPersistWith sqlSettings $(discoverEntities) -- ] -- [persistLowerCase| ... |] -- @ -- -- Likewise, to run migrations with all entity instances in scope, you'd write: -- -- @ -- migrateAll = migrateModels $(discoverEntities) -- @ -- -- Note that there is some odd behavior with Template Haskell and splicing -- groups. If you call 'discoverEntities' in the same module that defines -- 'PersistEntity' instances, you need to ensure they are in different top-level -- binding groups. You can write @$(pure [])@ at the top level to do this. -- -- @ -- -- Foo and Bar both export an instance of PersistEntity -- import Foo -- import Bar -- -- -- Since Foo and Bar are both imported, discoverEntities can find them here. -- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| -- User -- name Text -- age Int -- |] -- -- -- onlyFooBar is defined in the same 'top level group' as the above generated -- -- instance for User, so it isn't present in this list. -- onlyFooBar :: [EntityDef] -- onlyFooBar = $(discoverEntities) -- -- -- We can manually create a new binding group with this, which splices an -- -- empty list of declarations in. -- $(pure []) -- -- -- fooBarUser is able to see the 'User' instance. -- fooBarUser :: [EntityDef] -- fooBarUser = $(discoverEntities) -- @ -- -- @since 2.13.0.0 discoverEntities :: Q Exp discoverEntities = do instances <- reifyInstances ''PersistEntity [VarT (mkName "a")] let types = mapMaybe getDecType instances getDecType dec = case dec of InstanceD _moverlap [] typ _decs -> stripPersistEntity typ _ -> Nothing stripPersistEntity typ = case typ of AppT (ConT tyName) t | tyName == ''PersistEntity -> Just t _ -> Nothing fmap ListE $ forM types $ \typ -> do [e| entityDef (Proxy :: Proxy $(pure typ)) |] setNull :: NonEmpty UnboundFieldDef -> Bool setNull (fd :| fds) = let nullSetting = isNull fd isNull = (NotNullable /=) . isUnboundFieldNullable in if all ((nullSetting ==) . isNull) fds then nullSetting else error $ "foreign key columns must all be nullable or non-nullable" ++ show (fmap (unFieldNameHS . unboundFieldNameHS) (fd:fds))