persistent-2.18.1.0: Database/Persist/TH/Internal.hs
{-# 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.
--
-- For documentation on the domain specific language used for defining database
-- models, see "Database.Persist.Quasi".
module Database.Persist.TH.Internal
( -- * Parse entity defs
persistWith
, persistUpperCase
, persistLowerCase
, persistFileWith
, persistManyFileWith
-- * Turn @EntityDef@s into types
, mkPersist
, mkPersistWith
-- ** Configuring Entity Definition
, MkPersistSettings
, mkPersistSettings
, sqlSettings
-- *** Record Fields (for update/viewing settings)
, mpsBackend
, mpsGeneric
, mpsPrefixFields
, mpsFieldLabelModifier
, mpsAvoidHsKeyword
, mpsConstraintLabelModifier
, mpsEntityHaddocks
, mpsEntityJSON
, mpsGenerateLenses
, mpsDeriveInstances
, mpsCamelCaseCompositeKeySelector
, EntityJSON (..)
-- ** 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 (..)
, ToJSON (..)
, eitherDecodeStrict'
, object
, withObject
, (.:)
, (.:?)
, (.=)
)
import Data.Functor.Apply ((<.>))
#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 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 (asum, toList, traverse_)
import qualified Data.Set as Set
import Language.Haskell.TH.Lib
( appT
, conE
, conK
, conT
, litT
, strTyLit
, varE
, varP
, varT
)
#if MIN_VERSION_template_haskell(2,21,0)
import Language.Haskell.TH.Lib (defaultBndrFlag)
#endif
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
import Web.PathPieces (PathPiece (..))
import Database.Persist
import Database.Persist.Class.PersistEntity
import Database.Persist.Quasi
import Database.Persist.Quasi.Internal
import Database.Persist.Quasi.PersistSettings
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 :: Name -> [Pat] -> Pat
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 = \exp -> do
loc <- location
parseReferences ps [(Just $ sourceLocFromTHLoc loc, pack exp)]
, 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
-- '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 <https://github.com/yesodweb/persistent/issues/778 persistent#778> and
-- <https://github.com/yesodweb/persistent/pull/791 persistent#791> for more details.
--
-- @since 2.5.4
persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp
persistManyFileWith ps fps = do
mapM_ qAddDependentFile fps
ss <- mapM (\fp -> (fp,) <$> (qRunIO . getFileContents) fp) fps
parseReferences ps (map (\(fp, content) -> (Just $ sourceLoc fp, content)) ss)
where
sourceLoc path = SourceLoc{locFile = T.pack path, locStartLine = 1, locStartCol = 1}
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.16.0.0
parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp
parseReferences ps s = do
let
(warnings, res) = parse ps s
traverse_ (reportWarning . parserWarningMessage) $ warnings
case res of
Left errs -> fail $ renderErrors errs
Right r -> lift r
preprocessUnboundDefs
:: [EntityDef]
-> [UnboundEntityDef]
-> (M.Map EntityNameHS (), [UnboundEntityDef])
preprocessUnboundDefs preexistingEntities unboundDefs =
(embedEntityMap, noCycleEnts)
where
(embedEntityMap, noCycleEnts) =
embedEntityDefsMap preexistingEntities unboundDefs
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 ->
let
targetTableQualified =
fromMaybe targetTable (guessFieldReferenceQualified ufd)
in
( lift (ForeignRef targetTable)
, liftSqlTypeExp (SqlTypeReference targetTableQualified)
)
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 =
EntityNameHS <$> guessReferenceText (Just ft)
where
checkIdSuffix =
T.stripSuffix "Id"
guessReferenceText mft =
asum
[ do
FTTypeCon _ (checkIdSuffix -> Just tableName) <- mft
pure tableName
, do
FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- mft
pure tableName
, do
FTApp (FTTypeCon _ "Maybe") next <- mft
guessReferenceText (Just next)
]
guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReferenceQualified = guessReferenceQualified . unboundFieldType
guessReferenceQualified :: FieldType -> Maybe EntityNameHS
guessReferenceQualified ft =
EntityNameHS <$> guessReferenceText (Just ft)
where
checkIdSuffix =
T.stripSuffix "Id"
guessReferenceText mft =
asum
[ do
FTTypeCon mmod (checkIdSuffix -> Just tableName) <- mft
-- handle qualified name.
pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod
, do
FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- mft
-- handle qualified name.
pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod
, do
FTApp (FTTypeCon _ "Maybe") next <- mft
guessReferenceText (Just next)
]
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
let
mfieldTy = Just $ fieldType field
entName <-
EntityNameHS
<$> asum
[ do
FTTypeCon _ t <- mfieldTy
stripSuffix "Id" t
, do
FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- mfieldTy
pure entName
, do
FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- mfieldTy
stripSuffix "Id" t
]
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
mEmbedded _ (FTLit _) =
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
-- 'UnboundEntityDef's.
--
-- This function should be used if you are only defining a single block of
-- Persistent models for the entire application. If you intend on defining
-- multiple blocks in different fiels, see 'mkPersistWith' which allows you
-- to provide existing entity definitions so foreign key references work.
--
-- Example:
--
-- @
-- mkPersist 'sqlSettings' ['persistLowerCase'|
-- User
-- name Text
-- age Int
--
-- Dog
-- name Text
-- owner UserId
--
-- |]
-- @
--
-- Example from a file:
--
-- @
-- mkPersist 'sqlSettings' $('persistFileWith' 'lowerCaseSettings' "models.persistentmodels")
-- @
--
-- For full information on the 'QuasiQuoter' syntax, see
-- "Database.Persist.Quasi" documentation.
mkPersist
:: MkPersistSettings
-> [UnboundEntityDef]
-> Q [Dec]
mkPersist mps = mkPersistWith mps []
-- | Like 'mkPersist', but allows you to provide a @['EntityDef']@
-- representing the predefined entities. This function will include those
-- 'EntityDef' when looking for foreign key references.
--
-- You should use this if you intend on defining Persistent models in
-- multiple files.
--
-- Suppose we define a table @Foo@ which has no dependencies.
--
-- @
-- module DB.Foo where
--
-- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'|
-- Foo
-- name Text
-- |]
-- @
--
-- Then, we define a table @Bar@ which depends on @Foo@:
--
-- @
-- module DB.Bar where
--
-- import DB.Foo
--
-- 'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'|
-- Bar
-- fooId FooId
-- |]
-- @
--
-- Writing out the list of 'EntityDef' can be annoying. The
-- @$('discoverEntities')@ shortcut will work to reduce this boilerplate.
--
-- @
-- module DB.Quux where
--
-- import DB.Foo
-- import DB.Bar
--
-- 'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'|
-- Quux
-- name Text
-- fooId FooId
-- barId BarId
-- |]
-- @
--
-- @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 unboundIdType uidDef of
Nothing ->
instanceOkay
Just _ ->
case List.find isDefaultFieldAttr attrs of
Nothing ->
badInstance
Just _ -> do
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 that can be passed to the 'mkPersist' (mps) function to control what code is generated.
-- This is (just) the data type definition, so you will most likely want to use and adapt concrete values
-- like 'sqlSettings'.
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 names (and lens names) for generated entity data types.
--
-- Default: appends entity name and field name, equivalent to
--
-- @
-- mpsFieldLabelModifier = \\entityName fieldName -> entityName <> fieldName
-- @
--
-- to avoid duplicate record field collisions.
--
-- For example, with default 'sqlSettings' and
--
-- @
-- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'|
-- Person
-- name Text
-- age Int
-- |]
-- @
--
-- it will generate the entity data type
--
-- @
-- Person {
-- personName :: Text, -- generated field name
-- personAge :: Int -- generated field name
-- }
-- @
--
-- Note: this setting is ignored if the deprecated 'mpsPrefixFields' is set to False.
--
-- === __Example without entity name__
--
-- You may not want the entity name prefix for all fields, so use
--
-- @
-- 'mkPersistWith' ('sqlSettings' { mpsFieldLabelModifier = \\\_entityName fieldName -> fieldName }) [] ['persistLowerCase'|
-- Person
-- name Text
-- age Int
-- |]
-- @
--
-- instead. This will generate the entity data type
--
-- @
-- Person {
-- name :: Text,
-- age :: Int
-- }
-- @
--
-- When you have multiple entites with the same field name, you might need to
-- add @{-# LANGUAGE DuplicateRecordFields #-}@ for your code to compile.
--
-- @since 2.11.0.0
, mpsAvoidHsKeyword :: Text -> Text
-- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords.
--
-- Default: suffix "_".
--
-- @since 2.14.6.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 the deprecated 'mpsPrefixFields' is set to False.
--
-- @since 2.11.0.0
, mpsEntityHaddocks :: Bool
-- ^ Generate Haddocks from entity documentation comments. Default: False.
--
-- @since 2.14.6.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
, mpsCamelCaseCompositeKeySelector :: Bool
-- ^ Should we generate composite key accessors in the correct CamelCase style.
--
-- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'False',
-- then the field part of the accessor starts with the lowercase.
-- This is a legacy style.
--
-- @
-- data Key CompanyUser = CompanyUserKey
-- { companyUserKeycompanyId :: CompanyId
-- , companyUserKeyuserId :: UserId
-- }
-- @
--
-- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'True',
-- then field accessors are generated in CamelCase style.
--
-- @
-- data Key CompanyUser = CompanyUserKey
-- { companyUserKeyCompanyId :: CompanyId
-- , companyUserKeyUserId :: UserId
-- }
-- @
-- Default: False
--
-- @since 2.14.2.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 = (++)
, mpsAvoidHsKeyword = (++ "_")
, mpsConstraintLabelModifier = (++)
, mpsEntityHaddocks = False
, mpsEntityJSON =
Just
EntityJSON
{ entityToJSON = 'entityIdToJSON
, entityFromJSON = 'entityIdFromJSON
}
, mpsGenerateLenses = False
, mpsDeriveInstances = []
, mpsImplicitIdDef =
autoIncrementingInteger
, mpsCamelCaseCompositeKeySelector = False
}
-- | 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]]
let
dec =
DataD
[]
nameFinal
paramsFinal
Nothing
constrs
(stockDerives <> anyclassDerives)
conditionallyAddEntityHaddocks mps cols nameFinal entDef
pure dec
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, Maybe Text)]
cols = do
fieldDef <- getUnboundFieldDefs entDef
let
recordNameE =
fieldDefToRecordName mps entDef fieldDef
strictness =
if unboundFieldStrict fieldDef
then isStrict
else notStrict
fieldIdType =
maybeIdType mps entityMap fieldDef Nothing Nothing
fieldComments =
unboundFieldComments fieldDef
pure ((recordNameE, strictness, fieldIdType), fieldComments)
constrs
| unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef
| otherwise = [RecC (mkEntityDefName entDef) (map fst cols)]
sumCon fieldDef =
NormalC
(sumConstrName mps entDef fieldDef)
[(notStrict, maybeIdType mps entityMap fieldDef Nothing Nothing)]
#if MIN_VERSION_template_haskell(2,18,0)
conditionallyAddEntityHaddocks
:: Foldable t
=> MkPersistSettings
-> t ((Name, b, c), Maybe Text)
-> Name -> UnboundEntityDef -> Q ()
conditionallyAddEntityHaddocks mps cols nameFinal entDef =
when (mpsEntityHaddocks mps) $ do
forM_ cols $ \((name, _, _), maybeComments) -> do
case maybeComments of
Just comment -> addModFinalizer $
putDoc (DeclDoc name) (unpack comment)
Nothing -> pure ()
case entityComments (unboundEntityDef entDef) of
Just doc -> do
addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc)
_ -> pure ()
#else
conditionallyAddEntityHaddocks
:: Foldable t
=> MkPersistSettings
-> t ((Name, b, c), Maybe Text)
-> Name -> UnboundEntityDef -> Q ()
conditionallyAddEntityHaddocks _ _ _ _ =
pure ()
#endif
#if MIN_VERSION_template_haskell(2,15,0)
uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
uniqueTypeDec mps entityMap entDef =
DataInstD
[]
Nothing
(AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT))
Nothing
(fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef))
[]
#else
uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
uniqueTypeDec mps entityMap entDef =
DataInstD
[]
''Unique
[genericDataType mps (getUnboundEntityNameHS entDef) backendT]
Nothing
(fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef))
[]
#endif
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 Persistent disallows NULLables in an uniqueness "
, "constraint. The semantics of how NULL interacts with those constraints "
, "is non-trivial: most SQL implementations will not consider two NULL "
, "values to be equal for the purposes of an uniqueness constraint, "
, "allowing insertion of more than one row with a NULL value for the "
, "column in question. If you understand this feature of SQL and still "
, "intend to add a uniqueness constraint here, *** Use a \"!force\" "
, "attribute on the end of the line that defines your uniqueness "
, "constraint in order to disable this check. ***\n"
, "By default, this means using `getBy`, `insertBy`, or anything that fetches by unique key will NOT match if any of the fields are NULL."
]
-- | 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
-> Q Exp
fieldUpd con names record name new = do
pats <-
fmap mconcat $ forM names $ \k -> do
varName <- VarP <$> newName (nameBase k)
pure [(k, varName) | k /= name]
pure $
CaseE
record
[Match (RecP con pats) (NormalB body) []]
where
body =
RecConE
con
[ if k == name then (name, new) else (k, VarE k)
| k <- names
]
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)
(idClause :)
<$> if unboundEntitySum entDef
then
pure $
fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)
else
zipWithM
(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 = do
setter <- mkSetter
pure $
normalClause
[conp (filterConName mps entDef fieldDef) []]
(lens' `AppE` getter `AppE` setter)
where
defName = mkEntityDefName entDef
getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal)
mkSetter = do
updExpr <- fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName)
pure
$ LamE
[ conp 'Entity [VarP keyVar, VarP valName]
, VarP xName
]
$ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr
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
let
kd = mkKeyDeclaration useNewtype k recordType dec deriveClauses
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)
#if MIN_VERSION_template_haskell(2,15,0)
mkKeyDeclaration :: Bool -> Name -> Type -> Con -> [DerivClause] -> Dec
mkKeyDeclaration useNewtype k recordType dec deriveClauses =
if useNewtype
then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses
else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses
#else
mkKeyDeclaration :: Bool -> Name -> Type -> Con -> [DerivClause] -> Dec
mkKeyDeclaration useNewtype k recordType dec deriveClauses =
if useNewtype
then NewtypeInstD [] k [recordType] Nothing dec deriveClauses
else DataInstD [] k [recordType] Nothing [dec] deriveClauses
#endif
-- | 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
recordN <- newName "record"
FunD 'keyToValues . pure
<$> case unboundPrimarySpec entDef of
NaturalKey ucd -> do
normalClause [VarP recordN]
<$> toValuesPrimary recordN ucd
_ -> do
normalClause []
<$> [|(: []) . toPersistValue . $(pure $ unKeyExp entDef)|]
where
toValuesPrimary recName ucd =
ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd)
f recName fieldNameHS =
[|
toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE recName))
|]
keyFieldSel name =
fieldSel (keyConName entDef) (keyFieldName mps entDef name)
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)]
( List.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
let
keyFields' = fieldNameToRecordName mps entDef <$> unboundCompositeCols ucd
keyFieldNames' <- forM keyFields' $ \fieldName -> do
fieldVarName <- newName (nameBase fieldName)
return (fieldName, fieldVarName)
let
keyCon = keyConName entDef
constr =
List.foldl'
AppE
(ConE keyCon)
(VarE . snd <$> keyFieldNames')
keyFromRec = varP 'keyFromRecordM
fieldPat =
[ (fieldName, VarP fieldVarName)
| (fieldName, fieldVarName) <- toList keyFieldNames'
]
lam = LamE [RecP name fieldPat] constr
[d|
$(keyFromRec) = Just $(pure lam)
|]
_ ->
[d|$(varP 'keyFromRecordM) = Nothing|]
dtd <- dataTypeDec mps entityMap entDef
let
allEntDefs =
entityFieldTHCon <$> efthAllFields fields
allEntDefClauses =
entityFieldTHClause <$> efthAllFields fields
mkTabulateApply <- 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 conName []) ->
(conName, 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 =
fst $
List.foldl'
( \(acc, op) (n, _) ->
( InfixE
(Just acc)
op
(Just (VarE fromFieldName `AppE` ConE n))
, VarE '(<.>)
)
)
(ConE (mkEntityNameHSName entName), VarE '(<$>))
names'types
primaryKeyField =
fst $ getConNameAndType $ entityFieldTHCon $ entityFieldsTHPrimary fields
body <-
if isEntitySum $ unboundEntityDef entDef
then [|error "tabulateEntityApply does not make sense for sum type"|]
else
if null names'types
then
[|
(\k -> Entity k $(conE (mkEntityNameHSName entName)))
<$> $(varE fromFieldName) $(conE primaryKeyField)
|]
else
[|
Entity
<$> $(varE fromFieldName) $(conE primaryKeyField)
<.> $(pure mkEntityVal)
|]
pure $
FunD
'tabulateEntityApply
[ Clause [VarP fromFieldName] (NormalB body) []
]
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 conName []) ->
(conName, 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
, mkTabulateApply
, FunD 'entityDef [normalClause [WildP] entityDefExp]
, tpf
, FunD 'fromPersistValues fpv
, toFieldNames
, utv
, puk
, mkEntityFieldDataInstance genDataType allEntDefs
, FunD 'persistFieldDef allEntDefClauses
, mkTySynInstanceForBackend mps genDataType
, FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)]
, FunD 'fieldLens lensClauses
]
]
`mappend` lenses
)
`mappend` keyInstanceDecs
where
genDataType =
genericDataType mps entName backendT
entName =
getUnboundEntityNameHS preDef
#if MIN_VERSION_template_haskell(2,15,0)
mkEntityFieldDataInstance :: Type -> [Con] -> Dec
mkEntityFieldDataInstance genDataType allEntDefs =
DataInstD
[]
Nothing
(AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ"))
Nothing
allEntDefs
[]
#else
mkEntityFieldDataInstance :: Type -> [Con] -> Dec
mkEntityFieldDataInstance genDataType allEntDefs =
DataInstD
[]
''EntityField
[ genDataType
, VarT $ mkName "typ"
]
Nothing
allEntDefs
[]
#endif
#if MIN_VERSION_template_haskell(2,15,0)
mkTySynInstanceForBackend :: MkPersistSettings -> Type -> Dec
mkTySynInstanceForBackend mps genDataType =
TySynInstD
(TySynEqn
Nothing
(AppT (ConT ''PersistEntityBackend) genDataType)
(backendDataType mps))
#else
mkTySynInstanceForBackend :: MkPersistSettings -> Type -> Dec
mkTySynInstanceForBackend mps genDataType =
TySynInstD
''PersistEntityBackend
(TySynEqn
[genDataType]
(backendDataType mps))
#endif
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 <- typeErrorNoneCtx
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 [])
fieldUpdClause <- fieldUpd (mkEntityDefName ent) fieldNames a fieldName y
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]
fieldUpdClause
]
]
where
fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent
#if MIN_VERSION_template_haskell(2,21,0)
mkPlainTV
:: Name
-> TyVarBndr BndrVis
mkPlainTV n = PlainTV n defaultBndrFlag
mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV n = PlainTV n SpecifiedSpec
#elif MIN_VERSION_template_haskell(2,17,0)
mkPlainTV
:: Name
-> TyVarBndr ()
mkPlainTV n = PlainTV n ()
mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV n = PlainTV n SpecifiedSpec
#else
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
recordVarName <- newName "record_mkForeignKeysComposite"
let
mkFldE foreignName =
-- using coerce here to convince SqlBackendKey to go away
VarE 'coerce
`AppE` (VarE (fieldName foreignName) `AppE` VarE recordVarName)
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 =
List.foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE
fn =
FunD fname [normalClause [VarP recordVarName] 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'|
-- -- ...
-- |]
-- @
--
-- If you only have a single function, though, you don't need this. The
-- following is redundant:
--
-- @
-- 'share' ['mkPersist' 'sqlSettings'] ['persistLowerCase'|
-- -- ...
-- |]
-- @
--
-- Most functions require a full @['EntityDef']@, which can be provided
-- using @$('discoverEntities')@ for all entites in scope, or defining
-- 'mkEntityDefList' to define a list of entities from the given block.
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 _) =
List.foldl' (go' xs) (ConE (mkConstraintName name)) (toList $ fmap fst cols)
go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' xs front col =
let
col' =
fromMaybe
(error $ "failed in go' while looking up col=" <> show 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 '(.:?)
toKeyE = aesonKeyFromString
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]
( List.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
#if MIN_VERSION_aeson(2,0,0)
aesonKeyFromString :: Exp
aesonKeyFromString =
VarE 'Key.fromString
#else
aesonKeyFromString :: Exp
aesonKeyFromString =
VarE 'pack
#endif
mkClassP :: Name -> [Type] -> Pred
mkClassP cla tys = List.foldl AppT (ConT cla) tys
mkEqualP :: Type -> Type -> Pred
mkEqualP tleft tright = List.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 <- 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
-- <https://github.com/yesodweb/persistent/issues/412>
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 . avoidKeyword $ 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
avoidKeyword :: Text -> Text
avoidKeyword name =
if name `Set.member` haskellKeywords then mpsAvoidHsKeyword mps name else name
haskellKeywords :: Set.Set Text
haskellKeywords =
Set.fromList
[ "case"
, "class"
, "data"
, "default"
, "deriving"
, "do"
, "else"
, "if"
, "import"
, "in"
, "infix"
, "infixl"
, "infixr"
, "instance"
, "let"
, "module"
, "newtype"
, "of"
, "then"
, "type"
, "where"
, "_"
, "foreign"
]
-- | 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` fieldName
where
fieldName = modifyFieldName (unFieldNameHS fieldDef)
modifyFieldName =
if mpsCamelCaseCompositeKeySelector mps then upperFirst else id
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))