{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}
module Database.Persist.TH
(
persistWith
, persistUpperCase
, persistLowerCase
, persistFileWith
, persistManyFileWith
, mkPersist
, MkPersistSettings
, mpsBackend
, mpsGeneric
, mpsPrefixFields
, mpsEntityJSON
, mpsGenerateLenses
, mpsDeriveInstances
, EntityJSON(..)
, mkPersistSettings
, sqlSettings
, mkMigrate
, mkSave
, mkDeleteCascade
, mkEntityDefList
, share
, derivePersistField
, derivePersistFieldJSON
, persistFieldFromEntity
, lensPTH
, parseReferences
, embedEntityDefs
, fieldError
, AtLeastOneUniqueKey(..)
, OnlyOneUniqueKey(..)
) where
import Prelude hiding ((++), take, concat, splitAt, exp)
import Control.Monad (forM, mzero, filterM)
import Data.Aeson
( ToJSON (toJSON), FromJSON (parseJSON), (.=), object
, Value (Object), (.:), (.:?)
, eitherDecodeStrict'
)
import qualified Data.ByteString as BS
import Data.Char (toLower, toUpper)
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.List (foldl')
import qualified Data.List as List
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe)
import Data.Monoid ((<>), mappend, mconcat)
import Data.Proxy (Proxy (Proxy))
import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
import GHC.Generics (Generic)
import GHC.TypeLits
import Instances.TH.Lift ()
import Language.Haskell.TH.Lib (conT, varE)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.PathPieces (PathPiece(..))
import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..))
import Database.Persist
import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType)
import Database.Persist.Quasi
unHaskellNameForJSON :: HaskellName -> Text
unHaskellNameForJSON = fixTypeUnderscore . unHaskellName
where
fixTypeUnderscore = \case
"type" -> "type_"
name -> name
persistWith :: PersistSettings -> QuasiQuoter
persistWith ps = QuasiQuoter
{ quoteExp = parseReferences ps . pack
}
persistUpperCase :: QuasiQuoter
persistUpperCase = persistWith upperCaseSettings
persistLowerCase :: QuasiQuoter
persistLowerCase = persistWith lowerCaseSettings
persistFileWith :: PersistSettings -> FilePath -> Q Exp
persistFileWith ps fp = persistManyFileWith ps [fp]
persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp
persistManyFileWith ps fps = do
mapM_ qAddDependentFile fps
ss <- mapM (qRunIO . getFileContents) fps
let s = T.intercalate "\n" ss
parseReferences ps s
getFileContents :: FilePath -> IO Text
getFileContents = fmap decodeUtf8 . BS.readFile
embedEntityDefs :: [EntityDef] -> [EntityDef]
embedEntityDefs = snd . embedEntityDefsMap
embedEntityDefsMap :: [EntityDef] -> (M.Map HaskellName EmbedEntityDef, [EntityDef])
embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts)
where
noCycleEnts = map breakCycleEnt entsWithEmbeds
embedEntityMap = constructEmbedEntityMap entsWithEmbeds
entsWithEmbeds = map setEmbedEntity rawEnts
setEmbedEntity ent = ent
{ entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent
}
breakCycleEnt entDef =
let entName = entityHaskell entDef
in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef }
breakCycleField entName f = case f of
FieldDef { fieldReference = EmbedRef em } ->
f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }
_ ->
f
breakCycleEmbed ancestors em =
em { embeddedFields = breakCycleEmField (emName : ancestors) <$> embeddedFields em
}
where
emName = embeddedHaskell em
breakCycleEmField ancestors emf = case embeddedHaskell <$> membed of
Nothing -> emf
Just embName -> if embName `elem` ancestors
then emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }
else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed }
where
membed = emFieldEmbed emf
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences ps s = lift $
map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts
where
(embedEntityMap, noCycleEnts) = embedEntityDefsMap $ parse ps s
entityMap = constructEntityMap noCycleEnts
stripId :: FieldType -> Maybe Text
stripId (FTTypeCon Nothing t) = stripSuffix "Id" t
stripId _ = Nothing
foreignReference :: FieldDef -> Maybe HaskellName
foreignReference field = case fieldReference field of
ForeignRef ref _ -> Just ref
_ -> Nothing
data EntityDefSqlTypeExp
= EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp]
deriving Show
data SqlTypeExp
= SqlTypeExp FieldType
| SqlType' SqlType
deriving Show
instance Lift SqlTypeExp where
lift (SqlType' t) = lift t
lift (SqlTypeExp ftype) = return st
where
typ = ftToType ftype
mtyp = ConT ''Proxy `AppT` typ
typedNothing = SigE (ConE 'Proxy) mtyp
st = VarE 'sqlType `AppE` typedNothing
data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp]
instance Lift FieldsSqlTypeExp where
lift (FieldsSqlTypeExp fields sqlTypeExps) =
lift $ zipWith FieldSqlTypeExp fields sqlTypeExps
data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp
instance Lift FieldSqlTypeExp where
lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) =
[|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|]
instance Lift EntityDefSqlTypeExp where
lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
[|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps)
, entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)
}
|]
instance Lift ReferenceDef where
lift NoReference = [|NoReference|]
lift (ForeignRef name ft) = [|ForeignRef name ft|]
lift (EmbedRef em) = [|EmbedRef em|]
lift (CompositeRef cdef) = [|CompositeRef cdef|]
lift SelfReference = [|SelfReference|]
instance Lift EmbedEntityDef where
lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|]
instance Lift EmbedFieldDef where
lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|]
type EmbedEntityMap = M.Map HaskellName EmbedEntityDef
constructEmbedEntityMap :: [EntityDef] -> EmbedEntityMap
constructEmbedEntityMap =
M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent))
type EntityMap = M.Map HaskellName EntityDef
constructEntityMap :: [EntityDef] -> EntityMap
constructEntityMap =
M.fromList . fmap (\ent -> (entityHaskell ent, ent))
data FTTypeConDescr = FTKeyCon deriving Show
mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef
mEmbedded _ (FTTypeCon Just{} _) = Left Nothing
mEmbedded ents (FTTypeCon Nothing n) =
let name = HaskellName n
in maybe (Left Nothing) Right $ M.lookup name ents
mEmbedded ents (FTList x) = mEmbedded ents x
mEmbedded ents (FTApp x y) =
if x == FTTypeCon Nothing "Key"
then Left $ Just FTKeyCon
else mEmbedded ents y
setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef
setEmbedField entName allEntities field = field
{ fieldReference =
case fieldReference field of
NoReference ->
case mEmbedded allEntities (fieldType field) of
Left _ ->
case stripId $ fieldType field of
Nothing -> NoReference
Just name ->
case M.lookup (HaskellName name) allEntities of
Nothing -> NoReference
Just _ -> ForeignRef (HaskellName name)
(FTTypeCon (Just "Data.Int") "Int64")
Right em ->
if embeddedHaskell em /= entName
then EmbedRef em
else if maybeNullable field
then SelfReference
else case fieldType field of
FTList _ -> SelfReference
_ -> error $ unpack $ unHaskellName entName <> ": a self reference must be a Maybe"
existing -> existing
}
mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp
mkEntityDefSqlTypeExp emEntities entityMap ent =
EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent)
where
getSqlType field =
maybe
(defaultSqlTypeExp field)
(SqlType' . SqlOther)
(listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field)
defaultSqlTypeExp field =
case mEmbedded emEntities ftype of
Right _ -> SqlType' SqlString
Left (Just FTKeyCon) -> SqlType' SqlString
Left Nothing -> case fieldReference field of
ForeignRef refName ft -> case M.lookup refName entityMap of
Nothing -> SqlTypeExp ft
Just ent' -> case entityPrimary ent' of
Nothing -> SqlTypeExp ft
Just pdef -> case compositeFields pdef of
[] -> error "mkEntityDefSqlTypeExp: no composite fields"
[x] -> SqlTypeExp $ fieldType x
_ -> SqlType' $ SqlOther "Composite Reference"
CompositeRef _ -> SqlType' $ SqlOther "Composite Reference"
_ ->
case ftype of
FTList _ -> SqlType' SqlString
_ -> SqlTypeExp ftype
where
ftype = fieldType field
mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkPersist mps ents' = do
x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents
y <- fmap mconcat $ mapM (mkEntity entityMap mps) ents
z <- fmap mconcat $ mapM (mkJSON mps) ents
uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents
return $ mconcat [x, y, z, uniqueKeyInstances]
where
ents = map fixEntityDef ents'
entityMap = constructEntityMap ents
fixEntityDef :: EntityDef -> EntityDef
fixEntityDef ed =
ed { entityFields = filter keepField $ entityFields ed }
where
keepField fd = "MigrationOnly" `notElem` fieldAttrs fd &&
"SafeToRemove" `notElem` fieldAttrs fd
data MkPersistSettings = MkPersistSettings
{ mpsBackend :: Type
, mpsGeneric :: Bool
, mpsPrefixFields :: Bool
, mpsEntityJSON :: Maybe EntityJSON
, mpsGenerateLenses :: !Bool
, mpsDeriveInstances :: ![Name]
}
data EntityJSON = EntityJSON
{ entityToJSON :: Name
, entityFromJSON :: Name
}
mkPersistSettings
:: Type
-> MkPersistSettings
mkPersistSettings t = MkPersistSettings
{ mpsBackend = t
, mpsGeneric = False
, mpsPrefixFields = True
, mpsEntityJSON = Just EntityJSON
{ entityToJSON = 'entityIdToJSON
, entityFromJSON = 'entityIdFromJSON
}
, mpsGenerateLenses = False
, mpsDeriveInstances = []
}
sqlSettings :: MkPersistSettings
sqlSettings = mkPersistSettings $ ConT ''SqlBackend
recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text
recNameNoUnderscore mps dt f
| mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft
| otherwise = lowerFirst ft
where
ft = unHaskellName f
recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text
recName mps dt f =
addUnderscore $ recNameNoUnderscore mps dt f
where
addUnderscore
| mpsGenerateLenses mps = ("_" ++)
| otherwise = id
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 -> EntityDef -> Q Dec
dataTypeDec mps t = do
let entityInstances = map (mkName . unpack) $ entityDerives t
additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps
names = entityInstances <> additionalInstances
DataD [] nameFinal paramsFinal
Nothing
constrs
<$> fmap (pure . DerivClause Nothing) (mapM conT names)
where
mkCol x fd@FieldDef {..} =
(mkName $ unpack $ recName mps x fieldHaskell,
if fieldStrict then isStrict else notStrict,
maybeIdType mps fd Nothing Nothing
)
(nameFinal, paramsFinal)
| mpsGeneric mps = (nameG, [PlainTV backend])
| otherwise = (name, [])
nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic"
name = mkName $ unpack $ unHaskellName $ entityHaskell t
cols = map (mkCol $ entityHaskell t) $ entityFields t
backend = backendName
constrs
| entitySum t = map sumCon $ entityFields t
| otherwise = [RecC name cols]
sumCon fd = NormalC
(sumConstrName mps t fd)
[(notStrict, maybeIdType mps fd Nothing Nothing)]
sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat
[ if mpsPrefixFields mps
then unHaskellName $ entityHaskell t
else ""
, upperFirst $ unHaskellName fieldHaskell
, "Sum"
]
uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec
uniqueTypeDec mps t =
#if MIN_VERSION_template_haskell(2,15,0)
DataInstD [] Nothing
(AppT (ConT ''Unique) (genericDataType mps (entityHaskell t) backendT))
Nothing
(map (mkUnique mps t) $ entityUniques t)
(derivClause $ entityUniques t)
#else
DataInstD [] ''Unique
[genericDataType mps (entityHaskell t) backendT]
Nothing
(map (mkUnique mps t) $ entityUniques t)
(derivClause $ entityUniques t)
#endif
where
derivClause [] = []
derivClause _ = [DerivClause Nothing [ConT ''Show]]
mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) =
NormalC (mkName $ unpack constr) types
where
types =
map (go . flip lookup3 (entityFields t) . unHaskellName . fst) fields
force = "!force" `elem` attrs
go :: (FieldDef, IsNullable) -> (Strict, Type)
go (_, Nullable _) | not force = error nullErrMsg
go (fd, y) = (notStrict, maybeIdType mps fd Nothing (Just y))
lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable)
lookup3 s [] =
error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr
lookup3 x (fd@FieldDef {..}:rest)
| x == unHaskellName fieldHaskell = (fd, nullable fieldAttrs)
| otherwise = lookup3 x rest
nullErrMsg =
mconcat [ "Error: By default we disallow NULLables in an uniqueness "
, "constraint. The semantics of how NULL interacts with those "
, "constraints is non-trivial: two NULL values are not "
, "considered equal for the purposes of an uniqueness "
, "constraint. If you understand this feature, it is possible "
, "to use it your advantage. *** Use a \"!force\" attribute "
, "on the end of the line that defines your uniqueness "
, "constraint in order to disable this check. ***" ]
maybeIdType :: MkPersistSettings
-> FieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType mps fd mbackend mnull = maybeTyp mayNullable idtyp
where
mayNullable = case mnull of
(Just (Nullable ByMaybeAttr)) -> True
_ -> maybeNullable fd
idtyp = idType mps fd mbackend
backendDataType :: MkPersistSettings -> Type
backendDataType mps
| mpsGeneric mps = backendT
| otherwise = mpsBackend mps
genericDataType :: MkPersistSettings
-> HaskellName
-> Type
-> Type
genericDataType mps (HaskellName typ') backend
| mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend
| otherwise = ConT $ mkName $ unpack typ'
idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type
idType mps fd mbackend =
case foreignReference fd of
Just typ ->
ConT ''Key
`AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend)
Nothing -> ftToType $ fieldType fd
degen :: [Clause] -> [Clause]
degen [] =
let err = VarE 'error `AppE` LitE (StringL
"Degenerate case, should never happen")
in [normalClause [WildP] err]
degen x = x
mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec
mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do
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 pat = ConP (mkName constr) $ map VarP xs
sp <- [|SomePersistField|]
let bod = ListE $ map (AppE sp . VarE) xs
return $ normalClause [pat] bod
fieldCount = length fields
goSum :: FieldDef -> Int -> Q Clause
goSum fd idx = do
let name = sumConstrName mps ed fd
enull <- [|SomePersistField PersistNull|]
let beforeCount = idx - 1
afterCount = fieldCount - idx
before = replicate beforeCount enull
after = replicate afterCount enull
x <- newName "x"
sp <- [|SomePersistField|]
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 (mkName $ unpack $ unHaskellName 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 (mkName $ unpack $ unHaskellName constr) $ map VarP xs
tpv <- [|toPersistValue|]
let bod = ListE $ map (AppE tpv . VarE) 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)
mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]
mkFromPersistValues _ t@(EntityDef { entitySum = False }) =
fromValues t "fromPersistValues" entE $ entityFields t
where
entE = ConE $ mkName $ unpack entName
entName = unHaskellName $ entityHaskell t
mkFromPersistValues mps t@(EntityDef { entitySum = True }) = do
nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
clauses <- mkClauses [] $ entityFields t
return $ clauses `mappend` [normalClause [WildP] nothing]
where
entName = unHaskellName $ entityHaskell t
mkClauses _ [] = return []
mkClauses before (field:after) = do
x <- newName "x"
let null' = ConP 'PersistNull []
pat = ListP $ mconcat
[ map (const null') before
, [VarP x]
, map (const null') after
]
constr = ConE $ sumConstrName mps t 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
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
mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause]
mkLensClauses mps t = 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 t) []]
(lens' `AppE` getId `AppE` setId)
if entitySum t
then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields t)
else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields t)
where
toClause lens' getVal dot keyVar valName xName f = normalClause
[ConP (filterConName mps t f) []]
(lens' `AppE` getter `AppE` setter)
where
fieldName = mkName $ unpack $ recName mps (entityHaskell t) (fieldHaskell f)
getter = InfixE (Just $ VarE fieldName) dot (Just getVal)
setter = LamE
[ ConP 'Entity [VarP keyVar, VarP valName]
, VarP xName
]
$ ConE 'Entity `AppE` VarE keyVar `AppE` RecUpdE
(VarE valName)
[(fieldName, VarE xName)]
toSumClause lens' keyVar valName xName f = normalClause
[ConP (filterConName mps t f) []]
(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 t f) [VarP xName]) (NormalB $ VarE xName) []
: if length (entityFields t) > 1 then [emptyMatch] else []
setter = LamE
[ ConP 'Entity [VarP keyVar, WildP]
, VarP xName
]
$ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName)
mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec])
mkKeyTypeDec mps t = 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
#if MIN_VERSION_template_haskell(2,15,0)
cxti <- mapM conT i
let kd = if useNewtype
then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec [DerivClause (Just NewtypeStrategy) cxti]
else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] [DerivClause (Just StockStrategy) cxti]
#else
cxti <- mapM conT i
let kd = if useNewtype
then NewtypeInstD [] k [recordType] Nothing dec [DerivClause (Just NewtypeStrategy) cxti]
else DataInstD [] k [recordType] Nothing [dec] [DerivClause (Just StockStrategy) cxti]
#endif
return (kd, instDecs)
where
keyConE = keyConExp t
unKeyE = unKeyExp t
dec = RecC (keyConName t) (keyFields mps t)
k = ''Key
recordType = genericDataType mps (entityHaskell t) backendT
pfInstD =
[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
instances <- do
alwaysInstances <-
[d|deriving newtype instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType))
deriving newtype instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType))
deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType))
deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType))
deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType))
deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType))
deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType))
deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType))
deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType))
deriving newtype instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType))
deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType))
|]
if customKeyType then return alwaysInstances
else fmap (alwaysInstances `mappend`) backendKeyGenericI
return instances
useNewtype = pkNewtype mps t
customKeyType = not (defaultIdType t) || not useNewtype || isJust (entityPrimary t)
supplement :: [Name] -> [Name]
supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps)
keyIdName :: EntityDef -> Name
keyIdName = mkName . unpack . keyIdText
keyIdText :: EntityDef -> Text
keyIdText t = unHaskellName (entityHaskell t) `mappend` "Id"
unKeyName :: EntityDef -> Name
unKeyName t = mkName $ "un" `mappend` keyString t
unKeyExp :: EntityDef -> Exp
unKeyExp = VarE . unKeyName
backendT :: Type
backendT = VarT backendName
backendName :: Name
backendName = mkName "backend"
keyConName :: EntityDef -> Name
keyConName t = mkName $ resolveConflict $ keyString t
where
resolveConflict kn = if conflict then kn `mappend` "'" else kn
conflict = any ((== HaskellName "key") . fieldHaskell) $ entityFields t
keyConExp :: EntityDef -> Exp
keyConExp = ConE . keyConName
keyString :: EntityDef -> String
keyString = unpack . keyText
keyText :: EntityDef -> Text
keyText t = unHaskellName (entityHaskell t) ++ "Key"
pkNewtype :: MkPersistSettings -> EntityDef -> Bool
pkNewtype mps t = length (keyFields mps t) < 2
defaultIdType :: EntityDef -> Bool
defaultIdType t = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)
keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]
keyFields mps t = case entityPrimary t of
Just pdef -> map primaryKeyVar (compositeFields pdef)
Nothing -> if defaultIdType t
then [idKeyVar backendKeyType]
else [idKeyVar $ ftToType $ fieldType $ entityId t]
where
backendKeyType
| mpsGeneric mps = ConT ''BackendKey `AppT` backendT
| otherwise = ConT ''BackendKey `AppT` mpsBackend mps
idKeyVar ft = (unKeyName t, notStrict, ft)
primaryKeyVar fd = ( keyFieldName mps t fd
, notStrict
, ftToType $ fieldType fd
)
keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
keyFieldName mps t fd
| pkNewtype mps t = unKeyName t
| otherwise = mkName $ unpack $ lowerFirst (keyText t) `mappend` unHaskellName (fieldHaskell fd)
mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
mkKeyToValues mps t = do
(p, e) <- case entityPrimary t of
Nothing ->
([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|]
Just pdef ->
return $ toValuesPrimary pdef
return $ FunD 'keyToValues $ return $ normalClause p e
where
toValuesPrimary pdef =
( [VarP recordName]
, ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps t fd) `AppE` VarE recordName)) $ compositeFields pdef
)
recordName = mkName "record"
normalClause :: [Pat] -> Exp -> Clause
normalClause p e = Clause p (NormalB e) []
mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec
mkKeyFromValues _mps t = do
clauses <- case entityPrimary t of
Nothing -> do
e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
return [normalClause [] e]
Just pdef ->
fromValues t "keyFromValues" keyConE (compositeFields pdef)
return $ FunD 'keyFromValues clauses
where
keyConE = keyConExp t
headNote :: [PersistValue] -> PersistValue
headNote = \case
[x] -> x
xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs
fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause]
fromValues t funName conE fields = do
x <- newName "x"
let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: "
patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
suc <- patternSuccess
return [ suc, normalClause [VarP x] patternMatchFailure ]
where
tableName = unDBName (entityDB t)
patternSuccess =
case fields of
[] -> do
rightE <- [|Right|]
return $ normalClause [ListP []] (rightE `AppE` conE)
_ -> do
x1 <- newName "x1"
restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields]
(fpv1:mkPersistValues) <- mapM mkPersistValue fields
app1E <- [|(<$>)|]
let conApp = infixFromPersistValue app1E fpv1 conE x1
applyE <- [|(<*>)|]
let applyFromPersistValue = infixFromPersistValue applyE
return $ normalClause
[ListP $ map VarP (x1:restNames)]
(foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues))
infixFromPersistValue applyE fpv exp name =
UInfixE exp applyE (fpv `AppE` VarE name)
mkPersistValue field =
let fieldName = (unHaskellName (fieldHaskell field))
in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|]
fieldError :: Text -> Text -> Text -> Text
fieldError tableName fieldName err = mconcat
[ "Couldn't parse field `"
, fieldName
, "` from table `"
, tableName
, "`. "
, err
]
mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
mkEntity entityMap mps t = do
t' <- liftAndFixKeys entityMap t
let nameT = unHaskellName entName
let nameS = unpack nameT
let clazz = ConT ''PersistEntity `AppT` genDataType
tpf <- mkToPersistFields mps nameS t
fpv <- mkFromPersistValues mps t
utv <- mkUniqueToValues $ entityUniques t
puk <- mkUniqueKeys t
fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t
let primaryField = entityId t
fields <- mapM (mkField mps t) $ primaryField : entityFields t
toFieldNames <- mkToFieldNames $ entityUniques t
(keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t
keyToValues' <- mkKeyToValues mps t
keyFromValues' <- mkKeyFromValues mps t
let addSyn
| mpsGeneric mps = (:) $
TySynD (mkName nameS) [] $
genericDataType mps entName $ mpsBackend mps
| otherwise = id
lensClauses <- mkLensClauses mps t
lenses <- mkLenses mps t
let instanceConstraint = if not (mpsGeneric mps) then [] else
[mkClassP ''PersistStore [backendT]]
dtd <- dataTypeDec mps t
return $ addSyn $
dtd : mconcat fkc `mappend`
([ TySynD (keyIdName t) [] $
ConT ''Key `AppT` ConT (mkName nameS)
, instanceD instanceConstraint clazz
[ uniqueTypeDec mps t
, keyTypeDec
, keyToValues'
, keyFromValues'
, FunD 'entityDef [normalClause [WildP] t']
, tpf
, FunD 'fromPersistValues fpv
, toFieldNames
, utv
, puk
#if MIN_VERSION_template_haskell(2,15,0)
, DataInstD
[]
Nothing
(AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ"))
Nothing
(map fst fields)
[]
#else
, DataInstD
[]
''EntityField
[ genDataType
, VarT $ mkName "typ"
]
Nothing
(map fst fields)
[]
#endif
, FunD 'persistFieldDef (map snd fields)
#if MIN_VERSION_template_haskell(2,15,0)
, TySynInstD
(TySynEqn
Nothing
(AppT (ConT ''PersistEntityBackend) genDataType)
(backendDataType mps))
#else
, TySynInstD
''PersistEntityBackend
(TySynEqn
[genDataType]
(backendDataType mps))
#endif
, FunD 'persistIdField [normalClause [] (ConE $ keyIdName t)]
, FunD 'fieldLens lensClauses
]
] `mappend` lenses) `mappend` keyInstanceDecs
where
genDataType = genericDataType mps entName backendT
entName = entityHaskell t
mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
mkUniqueKeyInstances mps t = do
requirePersistentExtensions
case entityUniques t of
[] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne
[_] -> mappend <$> singleUniqueKey <*> atLeastOneKey
(_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey
where
requireUniquesPName = mkName "requireUniquesP"
onlyUniquePName = mkName "onlyUniqueP"
typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx
typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx
withPersistStoreWriteCxt =
if mpsGeneric mps
then do
write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |]
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 (mkName "error") `AppE` LitE (StringL "impossible"))
)
[]
]
]
typeErrorAtLeastOne :: Q [Dec]
typeErrorAtLeastOne = do
let impl = mkImpossible requireUniquesPName
cxt <- typeErrorMultipleCtx
pure [instanceD cxt atLeastOneUniqueKeyClass impl]
singleUniqueKey :: Q [Dec]
singleUniqueKey = do
expr <- [e| head . persistUniqueKeys|]
let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]]
cxt <- withPersistStoreWriteCxt
pure [instanceD cxt onlyOneUniqueKeyClass impl]
atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType
onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType
atLeastOneKey :: Q [Dec]
atLeastOneKey = do
expr <- [e| NEL.fromList . persistUniqueKeys|]
let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]]
cxt <- withPersistStoreWriteCxt
pure [instanceD cxt atLeastOneUniqueKeyClass impl]
genDataType = genericDataType mps (entityHaskell t) backendT
entityText :: EntityDef -> Text
entityText = unHaskellName . entityHaskell
mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec]
mkLenses mps _ | not (mpsGenerateLenses mps) = return []
mkLenses _ ent | entitySum ent = return []
mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
lensName = mkName $ unpack lensName'
fieldName = mkName $ unpack $ "_" ++ lensName'
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"
backend1 = backendName
backend2 = backendName
aT = maybeIdType mps field (Just backend1) Nothing
bT = maybeIdType mps field (Just backend2) Nothing
mkST backend = genericDataType mps (entityHaskell ent) (VarT backend)
sT = mkST backend1
tT = mkST backend2
t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2
vars = PlainTV fT
: (if mpsGeneric mps then [PlainTV backend1] else [])
return
[ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $
(aT `arrow` (VarT fT `AppT` bT)) `arrow`
(sT `arrow` (VarT fT `AppT` tT))
, FunD lensName $ return $ Clause
[VarP fN, VarP aN]
(NormalB $ fmapE
`AppE` setter
`AppE` (f `AppE` needle))
[ FunD needleN [normalClause [] (VarE fieldName `AppE` a)]
, FunD setterN $ return $ normalClause
[VarP yN]
(RecUpdE a
[ (fieldName, y)
])
]
]
mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
mkForeignKeysComposite mps t ForeignDef {..} = do
let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f
let fname = fieldName foreignConstraintNameHaskell
let reftableString = unpack $ unHaskellName foreignRefTableHaskell
let reftableKeyName = mkName $ reftableString `mappend` "Key"
let tablename = mkName $ unpack $ entityText t
recordName <- newName "record"
let fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName)
`AppE` VarE recordName) foreignFields
let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE
let fn = FunD fname [normalClause [VarP recordName] mkKeyE]
let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString)
let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2
return [sig, fn]
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 = map (unHaskellName . fieldHaskell) (entityFields (entityDef (Just entity)))
fieldsAsPersistValues = map toPersistValue $ toPersistFields entity
entityFromPersistValueHelper :: (PersistEntity record)
=> [String]
-> PersistValue
-> Either Text record
entityFromPersistValueHelper columnNames pv = do
(persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv
let columnMap = HM.fromList persistMap
lookupPersistValueByColumnName :: String -> PersistValue
lookupPersistValueByColumnName columnName =
fromMaybe PersistNull (HM.lookup (pack columnName) columnMap)
fromPersistValues $ map lookupPersistValueByColumnName columnNames
persistFieldFromEntity :: MkPersistSettings -> EntityDef -> 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 entDef) backendT
entFields = entityFields entDef
columnNames = map (unpack . unHaskellName . fieldHaskell) entFields
share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]
share fs x = mconcat <$> mapM ($ x) fs
mkSave :: String -> [EntityDef] -> Q [Dec]
mkSave name' defs' = do
let name = mkName name'
defs <- lift defs'
return [ SigD name $ ListT `AppT` ConT ''EntityDef
, FunD name [normalClause [] defs]
]
data Dep = Dep
{ depTarget :: HaskellName
, depSourceTable :: HaskellName
, depSourceField :: HaskellName
, depSourceNull :: IsNullable
}
mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkDeleteCascade mps defs = do
let deps = concatMap getDeps defs
mapM (go deps) defs
where
getDeps :: EntityDef -> [Dep]
getDeps def =
concatMap getDeps' $ entityFields $ fixEntityDef def
where
getDeps' :: FieldDef -> [Dep]
getDeps' field@FieldDef {..} =
case foreignReference field of
Just name ->
return Dep
{ depTarget = name
, depSourceTable = entityHaskell def
, depSourceField = fieldHaskell
, depSourceNull = nullable fieldAttrs
}
Nothing -> []
go :: [Dep] -> EntityDef -> Q Dec
go allDeps EntityDef{entityHaskell = name} = do
let deps = filter (\x -> depTarget x == name) allDeps
key <- newName "key"
let del = VarE 'delete
let dcw = VarE 'deleteCascadeWhere
just <- [|Just|]
filt <- [|Filter|]
eq <- [|Eq|]
value <- [|FilterValue|]
let mkStmt :: Dep -> Stmt
mkStmt dep = NoBindS
$ dcw `AppE`
ListE
[ filt `AppE` ConE filtName
`AppE` (value `AppE` val (depSourceNull dep))
`AppE` eq
]
where
filtName = filterConName' mps (depSourceTable dep) (depSourceField dep)
val (Nullable ByMaybeAttr) = just `AppE` VarE key
val _ = VarE key
let stmts :: [Stmt]
stmts = map mkStmt deps `mappend`
[NoBindS $ del `AppE` VarE key]
let entityT = genericDataType mps name backendT
return $
instanceD
[ mkClassP ''PersistQuery [backendT]
, mkEqualP (ConT ''PersistEntityBackend `AppT` entityT) (ConT ''BaseBackend `AppT` backendT)
]
(ConT ''DeleteCascade `AppT` entityT `AppT` backendT)
[ FunD 'deleteCascade
[normalClause [VarP key] (DoE stmts)]
]
mkEntityDefList
:: String
-> [EntityDef]
-> Q [Dec]
mkEntityDefList entityList entityDefs = do
let entityListName = mkName entityList
edefs <- fmap ListE
. forM entityDefs
$ \(EntityDef { entityHaskell = HaskellName haskellName }) ->
let entityType = conT (mkName (T.unpack haskellName))
in [|entityDef (Proxy :: Proxy $(entityType))|]
typ <- [t|[EntityDef]|]
pure
[ SigD entityListName typ
, ValD (VarP entityListName) (NormalB edefs) []
]
mkUniqueKeys :: EntityDef -> Q Dec
mkUniqueKeys def | entitySum def =
return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])]
mkUniqueKeys def = do
c <- clause
return $ FunD 'persistUniqueKeys [c]
where
clause = do
xs <- forM (entityFields def) $ \fd -> do
let x = fieldHaskell fd
x' <- newName $ '_' : unpack (unHaskellName x)
return (x, x')
let pcs = map (go xs) $ entityUniques def
let pat = ConP
(mkName $ unpack $ unHaskellName $ entityHaskell def)
(map (VarP . snd) xs)
return $ normalClause [pat] (ListE pcs)
go :: [(HaskellName, Name)] -> UniqueDef -> Exp
go xs (UniqueDef name _ cols _) =
foldl' (go' xs) (ConE (mkName $ unpack $ unHaskellName name)) (map fst cols)
go' :: [(HaskellName, Name)] -> Exp -> HaskellName -> Exp
go' xs front col =
let Just col' = lookup col xs
in front `AppE` VarE col'
sqlTypeFunD :: Exp -> Dec
sqlTypeFunD st = FunD 'sqlType
[ normalClause [WildP] st ]
typeInstanceD :: Name
-> Bool
-> Type -> [Dec] -> Dec
typeInstanceD clazz hasBackend typ =
instanceD ctx (ConT clazz `AppT` typ)
where
ctx
| hasBackend = [mkClassP ''PersistStore [backendT]]
| otherwise = []
persistFieldInstanceD :: Bool
-> Type -> [Dec] -> Dec
persistFieldInstanceD = typeInstanceD ''PersistField
persistFieldSqlInstanceD :: Bool
-> Type -> [Dec] -> Dec
persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql
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
]
]
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
]
]
mkMigrate :: String -> [EntityDef] -> Q [Dec]
mkMigrate fun allDefs = do
body' <- body
return
[ SigD (mkName fun) typ
, FunD (mkName fun) [normalClause [] body']
]
where
defs = filter isMigrated allDefs
isMigrated def = "no-migrate" `notElem` entityAttrs def
typ = ConT ''Migration
entityMap = constructEntityMap allDefs
body :: Q Exp
body =
case defs of
[] -> [|return ()|]
_ -> do
defsName <- newName "defs"
defsStmt <- do
defs' <- mapM (liftAndFixKeys entityMap) defs
let defsExp = ListE defs'
return $ LetS [ValD (VarP defsName) (NormalB defsExp) []]
stmts <- mapM (toStmt $ VarE defsName) defs
return (DoE $ defsStmt : stmts)
toStmt :: Exp -> EntityDef -> Q Stmt
toStmt defsExp ed = do
u <- liftAndFixKeys entityMap ed
m <- [|migrate|]
return $ NoBindS $ m `AppE` defsExp `AppE` u
liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp
liftAndFixKeys entityMap EntityDef{..} =
[|EntityDef
entityHaskell
entityDB
entityId
entityAttrs
$(ListE <$> mapM (liftAndFixKey entityMap) entityFields)
entityUniques
entityForeigns
entityDerives
entityExtra
entitySum
entityComments
|]
liftAndFixKey :: EntityMap -> FieldDef -> Q Exp
liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments) =
[|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|]
where
(fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $
case fieldRef of
ForeignRef refName _ft -> case M.lookup refName entityMap of
Nothing -> Nothing
Just ent ->
case fieldReference $ entityId ent of
fr@(ForeignRef _Name ft) -> Just (fr, lift $ SqlTypeExp ft)
_ -> Nothing
_ -> Nothing
instance Lift EntityDef where
lift EntityDef{..} =
[|EntityDef
entityHaskell
entityDB
entityId
entityAttrs
entityFields
entityUniques
entityForeigns
entityDerives
entityExtra
entitySum
entityComments
|]
instance Lift FieldDef where
lift (FieldDef a b c d e f g h) = [|FieldDef a b c d e f g h|]
instance Lift UniqueDef where
lift (UniqueDef a b c d) = [|UniqueDef a b c d|]
instance Lift CompositeDef where
lift (CompositeDef a b) = [|CompositeDef a b|]
instance Lift ForeignDef where
lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|]
instance Lift HaskellName where
lift (HaskellName t) = [|HaskellName t|]
instance Lift DBName where
lift (DBName t) = [|DBName t|]
instance Lift FieldType where
lift (FTTypeCon Nothing t) = [|FTTypeCon Nothing t|]
lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just x) t|]
lift (FTApp x y) = [|FTApp x y|]
lift (FTList x) = [|FTList x|]
instance Lift PersistFilter where
lift Eq = [|Eq|]
lift Ne = [|Ne|]
lift Gt = [|Gt|]
lift Lt = [|Lt|]
lift Ge = [|Ge|]
lift Le = [|Le|]
lift In = [|In|]
lift NotIn = [|NotIn|]
lift (BackendSpecificFilter x) = [|BackendSpecificFilter x|]
instance Lift PersistUpdate where
lift Assign = [|Assign|]
lift Add = [|Add|]
lift Subtract = [|Subtract|]
lift Multiply = [|Multiply|]
lift Divide = [|Divide|]
lift (BackendSpecificUpdate x) = [|BackendSpecificUpdate x|]
instance Lift SqlType where
lift SqlString = [|SqlString|]
lift SqlInt32 = [|SqlInt32|]
lift SqlInt64 = [|SqlInt64|]
lift SqlReal = [|SqlReal|]
lift (SqlNumeric x y) =
[|SqlNumeric (fromInteger x') (fromInteger y')|]
where
x' = fromIntegral x :: Integer
y' = fromIntegral y :: Integer
lift SqlBool = [|SqlBool|]
lift SqlDay = [|SqlDay|]
lift SqlTime = [|SqlTime|]
lift SqlDayTime = [|SqlDayTime|]
lift SqlBlob = [|SqlBlob|]
lift (SqlOther a) = [|SqlOther a|]
mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause)
mkField mps et cd = do
let con = ForallC
[]
[mkEqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing]
$ NormalC name []
bod <- lift cd
let cla = normalClause
[ConP name []]
bod
return (con, cla)
where
name = filterConName mps et cd
maybeNullable :: FieldDef -> Bool
maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr
filterConName :: MkPersistSettings
-> EntityDef
-> FieldDef
-> Name
filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field)
filterConName' :: MkPersistSettings
-> HaskellName
-> HaskellName
-> Name
filterConName' mps entity field = mkName $ unpack $ concat
[ if mpsPrefixFields mps || field == HaskellName "Id"
then unHaskellName entity
else ""
, upperFirst $ unHaskellName field
]
ftToType :: FieldType -> Type
ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t
ftToType (FTTypeCon (Just "Data.Int") "Int64") = ConT ''Int64
ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t]
ftToType (FTApp x y) = ftToType x `AppT` ftToType y
ftToType (FTList x) = ListT `AppT` ftToType x
infixr 5 ++
(++) :: Text -> Text -> Text
(++) = append
mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]
mkJSON _ def | ("json" `notElem` entityAttrs def) = return []
mkJSON mps def = do
pureE <- [|pure|]
apE' <- [|(<*>)|]
packE <- [|pack|]
dotEqualE <- [|(.=)|]
dotColonE <- [|(.:)|]
dotColonQE <- [|(.:?)|]
objectE <- [|object|]
obj <- newName "obj"
mzeroE <- [|mzero|]
xs <- mapM (newName . unpack . unHaskellNameForJSON . fieldHaskell)
$ entityFields def
let conName = mkName $ unpack $ unHaskellName $ entityHaskell def
typ = genericDataType mps (entityHaskell def) backendT
toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON']
toJSON' = FunD 'toJSON $ return $ normalClause
[ConP conName $ map VarP xs]
(objectE `AppE` ListE pairs)
pairs = zipWith toPair (entityFields def) xs
toPair f x = InfixE
(Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f)))
dotEqualE
(Just $ VarE x)
fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON']
parseJSON' = FunD 'parseJSON
[ normalClause [ConP 'Object [VarP obj]]
(foldl'
(\x y -> InfixE (Just x) apE' (Just y))
(pureE `AppE` ConE conName)
pulls
)
, normalClause [WildP] mzeroE
]
pulls = map toPull $ entityFields def
toPull f = InfixE
(Just $ VarE obj)
(if maybeNullable f then dotColonQE else dotColonE)
(Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f)
case mpsEntityJSON mps of
Nothing -> return [toJSONI, fromJSONI]
Just entityJSON -> do
entityJSONIs <- if mpsGeneric mps
then [d|
instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where
toJSON = $(varE (entityToJSON entityJSON))
instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where
parseJSON = $(varE (entityFromJSON entityJSON))
|]
else [d|
instance ToJSON (Entity $(pure typ)) where
toJSON = $(varE (entityToJSON entityJSON))
instance FromJSON (Entity $(pure typ)) where
parseJSON = $(varE (entityFromJSON entityJSON))
|]
return $ toJSONI : fromJSONI : entityJSONIs
mkClassP :: Name -> [Type] -> Pred
mkClassP cla tys = foldl AppT (ConT cla) tys
mkEqualP :: Type -> Type -> Pred
mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright]
notStrict :: Bang
notStrict = Bang NoSourceUnpackedness NoSourceStrictness
isStrict :: Bang
isStrict = Bang NoSourceUnpackedness SourceStrict
instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD = InstanceD Nothing
requirePersistentExtensions :: Q ()
requirePersistentExtensions = do
unenabledExtensions <- filterM (fmap not . isExtEnabled) requiredExtensions
case unenabledExtensions of
[] -> pure ()
[extension] -> fail $ mconcat
[ "Generating Persistent entities now requires the "
, show extension
, " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n"
, extensionToPragma extension
]
extensions -> fail $ mconcat
[ "Generating Persistent entities now requires the following language extensions:\n\n"
, List.intercalate "\n" (map show extensions)
, "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"
, List.intercalate "\n" (map extensionToPragma extensions)
]
where
requiredExtensions = [DerivingStrategies, GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances]
extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}"