{-# 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 #-}
module Database.Persist.TH
(
persistWith
, persistUpperCase
, persistLowerCase
, persistFileWith
, persistManyFileWith
, mkPersist
, mkPersistWith
, MkPersistSettings
, mpsBackend
, mpsGeneric
, mpsPrefixFields
, mpsFieldLabelModifier
, mpsConstraintLabelModifier
, mpsEntityJSON
, mpsGenerateLenses
, mpsDeriveInstances
, EntityJSON(..)
, mkPersistSettings
, sqlSettings
, ImplicitIdDef
, setImplicitIdDef
, mkMigrate
, migrateModels
, discoverEntities
, mkSave
, mkDeleteCascade
, mkEntityDefList
, share
, derivePersistField
, derivePersistFieldJSON
, persistFieldFromEntity
, lensPTH
, parseReferences
, embedEntityDefs
, fieldError
, AtLeastOneUniqueKey(..)
, OnlyOneUniqueKey(..)
, pkNewtype
) where
import Prelude hiding (concat, exp, splitAt, take, (++))
import Control.Monad
import Data.Aeson
( FromJSON(parseJSON)
, ToJSON(toJSON)
, Value(Object)
, eitherDecodeStrict'
, object
, withObject
, (.:)
, (.:?)
, (.=)
)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Key
#endif
import qualified Data.ByteString as BS
import Data.Char (toLower, toUpper)
import Data.Coerce
import Data.Data (Data)
import Data.Either
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.Ix (Ix)
import Data.List (foldl')
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import GHC.TypeLits
import Instances.TH.Lift ()
import Data.Foldable (toList)
import qualified Data.Set as Set
import Language.Haskell.TH.Lib
(appT, conE, conK, conT, litT, strTyLit, varE, varP, varT)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
import Web.PathPieces (PathPiece(..))
import Database.Persist
import Database.Persist.Quasi
import Database.Persist.Quasi.Internal
import Database.Persist.Sql
(Migration, PersistFieldSql, SqlBackend, migrate, sqlType)
import Database.Persist.EntityDef.Internal (EntityDef(..))
import Database.Persist.ImplicitIdDef (autoIncrementingInteger)
import Database.Persist.ImplicitIdDef.Internal
#if MIN_VERSION_template_haskell(2,18,0)
conp :: Name -> [Pat] -> Pat
conp name pats = ConP name [] pats
#else
conp :: Name -> [Pat] -> Pat
conp = Name -> [Pat] -> Pat
ConP
#endif
persistWith :: PersistSettings -> QuasiQuoter
persistWith :: PersistSettings -> QuasiQuoter
persistWith PersistSettings
ps = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp =
PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps (Text -> Q Exp) -> (String -> Text) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
, quotePat :: String -> Q Pat
quotePat =
String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"persistWith can't be used as pattern"
, quoteType :: String -> Q Type
quoteType =
String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"persistWith can't be used as type"
, quoteDec :: String -> Q [Dec]
quoteDec =
String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"persistWith can't be used as declaration"
}
persistUpperCase :: QuasiQuoter
persistUpperCase :: QuasiQuoter
persistUpperCase = PersistSettings -> QuasiQuoter
persistWith PersistSettings
upperCaseSettings
persistLowerCase :: QuasiQuoter
persistLowerCase :: QuasiQuoter
persistLowerCase = PersistSettings -> QuasiQuoter
persistWith PersistSettings
lowerCaseSettings
persistFileWith :: PersistSettings -> FilePath -> Q Exp
persistFileWith :: PersistSettings -> String -> Q Exp
persistFileWith PersistSettings
ps String
fp = PersistSettings -> [String] -> Q Exp
persistManyFileWith PersistSettings
ps [String
fp]
persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp
persistManyFileWith :: PersistSettings -> [String] -> Q Exp
persistManyFileWith PersistSettings
ps [String]
fps = do
(String -> Q ()) -> [String] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile [String]
fps
[Text]
ss <- (String -> Q Text) -> [String] -> Q [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO Text -> Q Text
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> (String -> IO Text) -> String -> Q Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
getFileContents) [String]
fps
let s :: Text
s = Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
ss
PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps Text
s
getFileContents :: FilePath -> IO Text
getFileContents :: String -> IO Text
getFileContents = (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (IO ByteString -> IO Text)
-> (String -> IO ByteString) -> String -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile
embedEntityDefs
:: [EntityDef]
-> [UnboundEntityDef]
-> [UnboundEntityDef]
embedEntityDefs :: [EntityDef] -> [UnboundEntityDef] -> [UnboundEntityDef]
embedEntityDefs [EntityDef]
eds = (EmbedEntityMap, [UnboundEntityDef]) -> [UnboundEntityDef]
forall a b. (a, b) -> b
snd ((EmbedEntityMap, [UnboundEntityDef]) -> [UnboundEntityDef])
-> ([UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef]))
-> [UnboundEntityDef]
-> [UnboundEntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
embedEntityDefsMap [EntityDef]
eds
embedEntityDefsMap
:: [EntityDef]
-> [UnboundEntityDef]
-> (EmbedEntityMap, [UnboundEntityDef])
embedEntityDefsMap :: [EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
embedEntityDefsMap [EntityDef]
existingEnts [UnboundEntityDef]
rawEnts =
(EmbedEntityMap
embedEntityMap, [UnboundEntityDef]
noCycleEnts)
where
noCycleEnts :: [UnboundEntityDef]
noCycleEnts = [UnboundEntityDef]
entsWithEmbeds
embedEntityMap :: EmbedEntityMap
embedEntityMap = [UnboundEntityDef] -> EmbedEntityMap
constructEmbedEntityMap [UnboundEntityDef]
entsWithEmbeds
entsWithEmbeds :: [UnboundEntityDef]
entsWithEmbeds = (UnboundEntityDef -> UnboundEntityDef)
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundEntityDef -> UnboundEntityDef
setEmbedEntity ([UnboundEntityDef]
rawEnts [UnboundEntityDef] -> [UnboundEntityDef] -> [UnboundEntityDef]
forall a. Semigroup a => a -> a -> a
<> (EntityDef -> UnboundEntityDef)
-> [EntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> UnboundEntityDef
unbindEntityDef [EntityDef]
existingEnts)
setEmbedEntity :: UnboundEntityDef -> UnboundEntityDef
setEmbedEntity UnboundEntityDef
ubEnt =
let
ent :: EntityDef
ent = UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ubEnt
in
UnboundEntityDef
ubEnt
{ unboundEntityDef :: EntityDef
unboundEntityDef =
([FieldDef] -> [FieldDef]) -> EntityDef -> EntityDef
overEntityFields
((FieldDef -> FieldDef) -> [FieldDef] -> [FieldDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef
forall a.
EntityNameHS -> Map EntityNameHS a -> FieldDef -> FieldDef
setEmbedField (EntityDef -> EntityNameHS
entityHaskell EntityDef
ent) EmbedEntityMap
embedEntityMap))
EntityDef
ent
}
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps Text
s = [UnboundEntityDef] -> Q Exp
forall t. Lift t => t -> Q Exp
lift ([UnboundEntityDef] -> Q Exp) -> [UnboundEntityDef] -> Q Exp
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [UnboundEntityDef]
parse PersistSettings
ps Text
s
preprocessUnboundDefs
:: [EntityDef]
-> [UnboundEntityDef]
-> (M.Map EntityNameHS (), [UnboundEntityDef])
preprocessUnboundDefs :: [EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
preprocessUnboundDefs [EntityDef]
preexistingEntities [UnboundEntityDef]
unboundDefs =
(EmbedEntityMap
embedEntityMap, [UnboundEntityDef]
noCycleEnts)
where
(EmbedEntityMap
embedEntityMap, [UnboundEntityDef]
noCycleEnts) =
[EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
embedEntityDefsMap [EntityDef]
preexistingEntities [UnboundEntityDef]
unboundDefs
stripId :: FieldType -> Maybe Text
stripId :: FieldType -> Maybe Text
stripId (FTTypeCon Maybe Text
Nothing Text
t) = Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
t
stripId FieldType
_ = Maybe Text
forall a. Maybe a
Nothing
liftAndFixKeys
:: MkPersistSettings
-> M.Map EntityNameHS a
-> EntityMap
-> UnboundEntityDef
-> Q Exp
liftAndFixKeys :: MkPersistSettings
-> Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp
liftAndFixKeys MkPersistSettings
mps Map EntityNameHS a
emEntities EntityMap
entityMap UnboundEntityDef
unboundEnt =
let
ent :: EntityDef
ent =
UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
unboundEnt
fields :: [UnboundFieldDef]
fields =
UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
unboundEnt
in
[|
ent
{ entityFields =
$(ListE <$> traverse combinedFixFieldDef fields)
, entityId =
$(fixPrimarySpec mps unboundEnt)
, entityForeigns =
$(fixUnboundForeignDefs (unboundForeignDefs unboundEnt))
}
|]
where
fixUnboundForeignDefs
:: [UnboundForeignDef]
-> Q Exp
fixUnboundForeignDefs :: [UnboundForeignDef] -> Q Exp
fixUnboundForeignDefs [UnboundForeignDef]
fdefs =
([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [UnboundForeignDef] -> (UnboundForeignDef -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnboundForeignDef]
fdefs UnboundForeignDef -> Q Exp
fixUnboundForeignDef
where
fixUnboundForeignDef :: UnboundForeignDef -> Q Exp
fixUnboundForeignDef UnboundForeignDef{ForeignDef
UnboundForeignFieldList
unboundForeignDef :: UnboundForeignDef -> ForeignDef
unboundForeignFields :: UnboundForeignDef -> UnboundForeignFieldList
unboundForeignDef :: ForeignDef
unboundForeignFields :: UnboundForeignFieldList
..} =
[|
unboundForeignDef
{ foreignFields =
$(lift fixForeignFields)
, foreignNullable =
$(lift fixForeignNullable)
, foreignRefTableDBName =
$(lift fixForeignRefTableDBName)
}
|]
where
fixForeignRefTableDBName :: EntityNameDB
fixForeignRefTableDBName =
EntityDef -> EntityNameDB
entityDB (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
parentDef)
foreignFieldNames :: NonEmpty FieldNameHS
foreignFieldNames =
case UnboundForeignFieldList
unboundForeignFields of
FieldListImpliedId NonEmpty FieldNameHS
ffns ->
NonEmpty FieldNameHS
ffns
FieldListHasReferences NonEmpty ForeignFieldReference
references ->
(ForeignFieldReference -> FieldNameHS)
-> NonEmpty ForeignFieldReference -> NonEmpty FieldNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> FieldNameHS
ffrSourceField NonEmpty ForeignFieldReference
references
parentDef :: UnboundEntityDef
parentDef =
case EntityNameHS -> EntityMap -> Maybe UnboundEntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
parentTableName EntityMap
entityMap of
Maybe UnboundEntityDef
Nothing ->
String -> UnboundEntityDef
forall a. HasCallStack => String -> a
error (String -> UnboundEntityDef) -> String -> UnboundEntityDef
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"Foreign table not defined: "
, EntityNameHS -> String
forall a. Show a => a -> String
show EntityNameHS
parentTableName
]
Just UnboundEntityDef
a ->
UnboundEntityDef
a
parentTableName :: EntityNameHS
parentTableName =
ForeignDef -> EntityNameHS
foreignRefTableHaskell ForeignDef
unboundForeignDef
fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)]
fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)]
fixForeignFields =
case UnboundForeignFieldList
unboundForeignFields of
FieldListImpliedId NonEmpty FieldNameHS
ffns ->
[FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)]
mkReferences ([FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)])
-> [FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)]
forall a b. (a -> b) -> a -> b
$ NonEmpty FieldNameHS -> [FieldNameHS]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty FieldNameHS
ffns
FieldListHasReferences NonEmpty ForeignFieldReference
references ->
NonEmpty (ForeignFieldDef, ForeignFieldDef)
-> [(ForeignFieldDef, ForeignFieldDef)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (ForeignFieldDef, ForeignFieldDef)
-> [(ForeignFieldDef, ForeignFieldDef)])
-> NonEmpty (ForeignFieldDef, ForeignFieldDef)
-> [(ForeignFieldDef, ForeignFieldDef)]
forall a b. (a -> b) -> a -> b
$ (ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef))
-> NonEmpty ForeignFieldReference
-> NonEmpty (ForeignFieldDef, ForeignFieldDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef)
convReferences NonEmpty ForeignFieldReference
references
where
mkReferences :: [FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)]
mkReferences [FieldNameHS]
fieldNames
| [FieldNameHS] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldNameHS]
fieldNames Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [ForeignFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ForeignFieldDef]
parentKeyFieldNames =
String -> [(ForeignFieldDef, ForeignFieldDef)]
forall a. HasCallStack => String -> a
error (String -> [(ForeignFieldDef, ForeignFieldDef)])
-> String -> [(ForeignFieldDef, ForeignFieldDef)]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"Foreign reference needs to have the same number "
, String
"of fields as the target table."
, String
"\n Table : "
, EntityNameHS -> String
forall a. Show a => a -> String
show (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
unboundEnt)
, String
"\n Foreign Table: "
, EntityNameHS -> String
forall a. Show a => a -> String
show EntityNameHS
parentTableName
, String
"\n Fields : "
, [FieldNameHS] -> String
forall a. Show a => a -> String
show [FieldNameHS]
fieldNames
, String
"\n Parent fields: "
, [FieldNameHS] -> String
forall a. Show a => a -> String
show ((ForeignFieldDef -> FieldNameHS)
-> [ForeignFieldDef] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldDef -> FieldNameHS
forall a b. (a, b) -> a
fst [ForeignFieldDef]
parentKeyFieldNames)
, String
"\n\nYou can use the References keyword to fix this."
]
| Bool
otherwise =
[ForeignFieldDef]
-> [ForeignFieldDef] -> [(ForeignFieldDef, ForeignFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((FieldNameHS -> ForeignFieldDef)
-> [FieldNameHS] -> [ForeignFieldDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
fieldStore) [FieldNameHS]
fieldNames) [ForeignFieldDef]
parentKeyFieldNames
where
parentKeyFieldNames
:: [(FieldNameHS, FieldNameDB)]
parentKeyFieldNames :: [ForeignFieldDef]
parentKeyFieldNames =
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
parentDef of
NaturalKey UnboundCompositeDef
ucd ->
(FieldNameHS -> ForeignFieldDef)
-> [FieldNameHS] -> [ForeignFieldDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
parentFieldStore) (UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd)
SurrogateKey UnboundIdDef
uid ->
[(Text -> FieldNameHS
FieldNameHS Text
"Id", UnboundIdDef -> FieldNameDB
unboundIdDBName UnboundIdDef
uid)]
DefaultKey FieldNameDB
dbName ->
[(Text -> FieldNameHS
FieldNameHS Text
"Id", FieldNameDB
dbName)]
withDbName :: FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
store FieldNameHS
fieldNameHS =
( FieldNameHS
fieldNameHS
, FieldStore -> FieldNameHS -> FieldNameDB
findDBName FieldStore
store FieldNameHS
fieldNameHS
)
convReferences
:: ForeignFieldReference
-> (ForeignFieldDef, ForeignFieldDef)
convReferences :: ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef)
convReferences ForeignFieldReference {FieldNameHS
ffrTargetField :: ForeignFieldReference -> FieldNameHS
ffrTargetField :: FieldNameHS
ffrSourceField :: FieldNameHS
ffrSourceField :: ForeignFieldReference -> FieldNameHS
..} =
( FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
fieldStore FieldNameHS
ffrSourceField
, FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
parentFieldStore FieldNameHS
ffrTargetField
)
fixForeignNullable :: Bool
fixForeignNullable =
(FieldNameHS -> Bool) -> NonEmpty FieldNameHS -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((IsNullable
NotNullable IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/=) (IsNullable -> Bool)
-> (FieldNameHS -> IsNullable) -> FieldNameHS -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> IsNullable
isForeignNullable) NonEmpty FieldNameHS
foreignFieldNames
where
isForeignNullable :: FieldNameHS -> IsNullable
isForeignNullable FieldNameHS
fieldNameHS =
case FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef FieldNameHS
fieldNameHS FieldStore
fieldStore of
Maybe UnboundFieldDef
Nothing ->
String -> IsNullable
forall a. HasCallStack => String -> a
error String
"Field name not present in map"
Just UnboundFieldDef
a ->
UnboundFieldDef -> IsNullable
isUnboundFieldNullable UnboundFieldDef
a
fieldStore :: FieldStore
fieldStore =
UnboundEntityDef -> FieldStore
mkFieldStore UnboundEntityDef
unboundEnt
parentFieldStore :: FieldStore
parentFieldStore =
UnboundEntityDef -> FieldStore
mkFieldStore UnboundEntityDef
parentDef
findDBName :: FieldStore -> FieldNameHS -> FieldNameDB
findDBName FieldStore
store FieldNameHS
fieldNameHS =
case FieldNameHS -> FieldStore -> Maybe FieldNameDB
getFieldDBName FieldNameHS
fieldNameHS FieldStore
store of
Maybe FieldNameDB
Nothing ->
String -> FieldNameDB
forall a. HasCallStack => String -> a
error (String -> FieldNameDB) -> String -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"findDBName: failed to fix dbname for: "
, FieldNameHS -> String
forall a. Show a => a -> String
show FieldNameHS
fieldNameHS
]
Just FieldNameDB
a->
FieldNameDB
a
combinedFixFieldDef :: UnboundFieldDef -> Q Exp
combinedFixFieldDef :: UnboundFieldDef -> Q Exp
combinedFixFieldDef ufd :: UnboundFieldDef
ufd@UnboundFieldDef{Bool
[FieldAttr]
Maybe Text
FieldNameHS
FieldNameDB
FieldCascade
FieldType
unboundFieldComments :: UnboundFieldDef -> Maybe Text
unboundFieldGenerated :: UnboundFieldDef -> Maybe Text
unboundFieldCascade :: UnboundFieldDef -> FieldCascade
unboundFieldType :: UnboundFieldDef -> FieldType
unboundFieldStrict :: UnboundFieldDef -> Bool
unboundFieldAttrs :: UnboundFieldDef -> [FieldAttr]
unboundFieldNameDB :: UnboundFieldDef -> FieldNameDB
unboundFieldNameHS :: UnboundFieldDef -> FieldNameHS
unboundFieldComments :: Maybe Text
unboundFieldGenerated :: Maybe Text
unboundFieldCascade :: FieldCascade
unboundFieldType :: FieldType
unboundFieldStrict :: Bool
unboundFieldAttrs :: [FieldAttr]
unboundFieldNameDB :: FieldNameDB
unboundFieldNameHS :: FieldNameHS
..} =
[|
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 :: SqlTypeExp
sqlTypeExp =
Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
forall a.
Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
getSqlType Map EntityNameHS a
emEntities EntityMap
entityMap UnboundFieldDef
ufd
FieldDef FieldNameHS
_x FieldNameDB
_ FieldType
_ SqlType
_ [FieldAttr]
_ Bool
_ ReferenceDef
_ FieldCascade
_ Maybe Text
_ Maybe Text
_ Bool
_ =
String -> FieldDef
forall a. HasCallStack => String -> a
error String
"need to update this record wildcard match"
(Q Exp
fieldRef', Q Exp
sqlTyp') =
case EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
ufd of
Just EntityNameHS
targetTable ->
(ReferenceDef -> Q Exp
forall t. Lift t => t -> Q Exp
lift (EntityNameHS -> ReferenceDef
ForeignRef EntityNameHS
targetTable), SqlTypeExp -> Q Exp
liftSqlTypeExp (EntityNameHS -> SqlTypeExp
SqlTypeReference EntityNameHS
targetTable))
Maybe EntityNameHS
Nothing ->
(ReferenceDef -> Q Exp
forall t. Lift t => t -> Q Exp
lift ReferenceDef
NoReference, SqlTypeExp -> Q Exp
liftSqlTypeExp SqlTypeExp
sqlTypeExp)
data FieldStore
= FieldStore
{ FieldStore -> Map FieldNameHS UnboundFieldDef
fieldStoreMap :: M.Map FieldNameHS UnboundFieldDef
, FieldStore -> Maybe FieldNameDB
fieldStoreId :: Maybe FieldNameDB
, FieldStore -> UnboundEntityDef
fieldStoreEntity :: UnboundEntityDef
}
mkFieldStore :: UnboundEntityDef -> FieldStore
mkFieldStore :: UnboundEntityDef -> FieldStore
mkFieldStore UnboundEntityDef
ued =
FieldStore :: Map FieldNameHS UnboundFieldDef
-> Maybe FieldNameDB -> UnboundEntityDef -> FieldStore
FieldStore
{ fieldStoreEntity :: UnboundEntityDef
fieldStoreEntity = UnboundEntityDef
ued
, fieldStoreMap :: Map FieldNameHS UnboundFieldDef
fieldStoreMap =
[(FieldNameHS, UnboundFieldDef)] -> Map FieldNameHS UnboundFieldDef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
([(FieldNameHS, UnboundFieldDef)]
-> Map FieldNameHS UnboundFieldDef)
-> [(FieldNameHS, UnboundFieldDef)]
-> Map FieldNameHS UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ (UnboundFieldDef -> (FieldNameHS, UnboundFieldDef))
-> [UnboundFieldDef] -> [(FieldNameHS, UnboundFieldDef)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\UnboundFieldDef
ufd ->
( UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
ufd
, UnboundFieldDef
ufd
)
)
([UnboundFieldDef] -> [(FieldNameHS, UnboundFieldDef)])
-> [UnboundFieldDef] -> [(FieldNameHS, UnboundFieldDef)]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs
(UnboundEntityDef -> [UnboundFieldDef])
-> UnboundEntityDef -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef
ued
, fieldStoreId :: Maybe FieldNameDB
fieldStoreId =
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
ued of
NaturalKey UnboundCompositeDef
_ ->
Maybe FieldNameDB
forall a. Maybe a
Nothing
SurrogateKey UnboundIdDef
fd ->
FieldNameDB -> Maybe FieldNameDB
forall a. a -> Maybe a
Just (FieldNameDB -> Maybe FieldNameDB)
-> FieldNameDB -> Maybe FieldNameDB
forall a b. (a -> b) -> a -> b
$ UnboundIdDef -> FieldNameDB
unboundIdDBName UnboundIdDef
fd
DefaultKey FieldNameDB
n ->
FieldNameDB -> Maybe FieldNameDB
forall a. a -> Maybe a
Just FieldNameDB
n
}
getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB
getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB
getFieldDBName FieldNameHS
name FieldStore
fs
| Text -> FieldNameHS
FieldNameHS Text
"Id" FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== FieldNameHS
name =
FieldStore -> Maybe FieldNameDB
fieldStoreId FieldStore
fs
| Bool
otherwise =
UnboundFieldDef -> FieldNameDB
unboundFieldNameDB (UnboundFieldDef -> FieldNameDB)
-> Maybe UnboundFieldDef -> Maybe FieldNameDB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef FieldNameHS
name FieldStore
fs
getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef FieldNameHS
fieldNameHS FieldStore
fs =
FieldNameHS
-> Map FieldNameHS UnboundFieldDef -> Maybe UnboundFieldDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FieldNameHS
fieldNameHS (FieldStore -> Map FieldNameHS UnboundFieldDef
fieldStoreMap FieldStore
fs)
extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
EntityMap
entityMap UnboundFieldDef
fieldDef = do
EntityNameHS
refName <- UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference UnboundFieldDef
fieldDef
UnboundEntityDef
ent <- EntityNameHS -> EntityMap -> Maybe UnboundEntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
refName EntityMap
entityMap
EntityNameHS -> Maybe EntityNameHS
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EntityNameHS -> Maybe EntityNameHS)
-> EntityNameHS -> Maybe EntityNameHS
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS) -> EntityDef -> EntityNameHS
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent
guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference = FieldType -> Maybe EntityNameHS
guessReference (FieldType -> Maybe EntityNameHS)
-> (UnboundFieldDef -> FieldType)
-> UnboundFieldDef
-> Maybe EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldType
unboundFieldType
guessReference :: FieldType -> Maybe EntityNameHS
guessReference :: FieldType -> Maybe EntityNameHS
guessReference FieldType
ft =
case FieldType
ft of
FTTypeCon Maybe Text
Nothing (Text -> Text -> Maybe Text
T.stripSuffix Text
"Id" -> Just Text
tableName) ->
EntityNameHS -> Maybe EntityNameHS
forall a. a -> Maybe a
Just (Text -> EntityNameHS
EntityNameHS Text
tableName)
FTApp (FTTypeCon Maybe Text
Nothing Text
"Key") (FTTypeCon Maybe Text
Nothing Text
tableName) ->
EntityNameHS -> Maybe EntityNameHS
forall a. a -> Maybe a
Just (Text -> EntityNameHS
EntityNameHS Text
tableName)
FieldType
_ ->
Maybe EntityNameHS
forall a. Maybe a
Nothing
mkDefaultKey
:: MkPersistSettings
-> FieldNameDB
-> EntityNameHS
-> FieldDef
mkDefaultKey :: MkPersistSettings -> FieldNameDB -> EntityNameHS -> FieldDef
mkDefaultKey MkPersistSettings
mps FieldNameDB
pk EntityNameHS
unboundHaskellName =
let
iid :: ImplicitIdDef
iid =
MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef MkPersistSettings
mps
in
(FieldDef -> FieldDef)
-> (FieldAttr -> FieldDef -> FieldDef)
-> Maybe FieldAttr
-> FieldDef
-> FieldDef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldDef -> FieldDef
forall a. a -> a
id FieldAttr -> FieldDef -> FieldDef
addFieldAttr (Text -> FieldAttr
FieldAttrDefault (Text -> FieldAttr) -> Maybe Text -> Maybe FieldAttr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Text
iidDefault ImplicitIdDef
iid) (FieldDef -> FieldDef) -> FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$
(FieldDef -> FieldDef)
-> (FieldAttr -> FieldDef -> FieldDef)
-> Maybe FieldAttr
-> FieldDef
-> FieldDef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldDef -> FieldDef
forall a. a -> a
id FieldAttr -> FieldDef -> FieldDef
addFieldAttr (Integer -> FieldAttr
FieldAttrMaxlen (Integer -> FieldAttr) -> Maybe Integer -> Maybe FieldAttr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Integer
iidMaxLen ImplicitIdDef
iid) (FieldDef -> FieldDef) -> FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$
FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' FieldNameDB
pk EntityNameHS
unboundHaskellName (ImplicitIdDef -> SqlType
iidFieldSqlType ImplicitIdDef
iid)
fixPrimarySpec
:: MkPersistSettings
-> UnboundEntityDef
-> Q Exp
fixPrimarySpec :: MkPersistSettings -> UnboundEntityDef -> Q Exp
fixPrimarySpec MkPersistSettings
mps UnboundEntityDef
unboundEnt= do
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
unboundEnt of
DefaultKey FieldNameDB
pk ->
EntityIdDef -> Q Exp
forall t. Lift t => t -> Q Exp
lift (EntityIdDef -> Q Exp) -> EntityIdDef -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldDef -> EntityIdDef
EntityIdField (FieldDef -> EntityIdDef) -> FieldDef -> EntityIdDef
forall a b. (a -> b) -> a -> b
$
MkPersistSettings -> FieldNameDB -> EntityNameHS -> FieldDef
mkDefaultKey MkPersistSettings
mps FieldNameDB
pk EntityNameHS
unboundHaskellName
SurrogateKey UnboundIdDef
uid -> do
let
entNameHS :: EntityNameHS
entNameHS =
UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
unboundEnt
fieldTyp :: FieldType
fieldTyp =
FieldType -> Maybe FieldType -> FieldType
forall a. a -> Maybe a -> a
fromMaybe (EntityNameHS -> FieldType
mkKeyConType EntityNameHS
entNameHS) (UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
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 UnboundCompositeDef
ucd ->
[| EntityIdNaturalKey $(bindCompositeDef unboundEnt ucd) |]
where
unboundHaskellName :: EntityNameHS
unboundHaskellName =
UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
unboundEnt
bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
bindCompositeDef UnboundEntityDef
ued UnboundCompositeDef
ucd = do
Exp
fieldDefs <-
([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [FieldNameHS] -> (FieldNameHS -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd) ((FieldNameHS -> Q Exp) -> Q [Exp])
-> (FieldNameHS -> Q Exp) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \FieldNameHS
col ->
UnboundEntityDef -> FieldNameHS -> Q Exp
mkLookupEntityField UnboundEntityDef
ued FieldNameHS
col
[|
CompositeDef
{ compositeFields =
NEL.fromList $(pure fieldDefs)
, compositeAttrs =
$(lift $ unboundCompositeAttrs ucd)
}
|]
getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
getSqlType :: Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
getSqlType Map EntityNameHS a
emEntities EntityMap
entityMap UnboundFieldDef
field =
SqlTypeExp -> (Text -> SqlTypeExp) -> Maybe Text -> SqlTypeExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
forall a.
Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
defaultSqlTypeExp Map EntityNameHS a
emEntities EntityMap
entityMap UnboundFieldDef
field)
(SqlType -> SqlTypeExp
SqlType' (SqlType -> SqlTypeExp) -> (Text -> SqlType) -> Text -> SqlTypeExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SqlType
SqlOther)
([Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (FieldAttr -> Maybe Text) -> [FieldAttr] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldAttr -> Maybe Text
attrSqlType ([FieldAttr] -> [Text]) -> [FieldAttr] -> [Text]
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs UnboundFieldDef
field)
defaultSqlTypeExp :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
defaultSqlTypeExp :: Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
defaultSqlTypeExp Map EntityNameHS a
emEntities EntityMap
entityMap UnboundFieldDef
field =
case Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
emEntities FieldType
ftype of
Right EntityNameHS
_ ->
SqlType -> SqlTypeExp
SqlType' SqlType
SqlString
Left (Just (FTKeyCon Text
ty)) ->
FieldType -> SqlTypeExp
SqlTypeExp (Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
ty)
Left Maybe FTTypeConDescr
Nothing ->
case EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
field of
Just EntityNameHS
refName ->
case EntityNameHS -> EntityMap -> Maybe UnboundEntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
refName EntityMap
entityMap of
Maybe UnboundEntityDef
Nothing ->
FieldType -> SqlTypeExp
SqlTypeExp FieldType
ftype
Just UnboundEntityDef
_ ->
EntityNameHS -> SqlTypeExp
SqlTypeReference EntityNameHS
refName
Maybe EntityNameHS
_ ->
case FieldType
ftype of
FTList FieldType
_ ->
SqlType -> SqlTypeExp
SqlType' SqlType
SqlString
FieldType
_ ->
FieldType -> SqlTypeExp
SqlTypeExp FieldType
ftype
where
ftype :: FieldType
ftype = UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
field
attrSqlType :: FieldAttr -> Maybe Text
attrSqlType :: FieldAttr -> Maybe Text
attrSqlType = \case
FieldAttrSqltype Text
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
FieldAttr
_ -> Maybe Text
forall a. Maybe a
Nothing
data SqlTypeExp
= SqlTypeExp FieldType
| SqlType' SqlType
| SqlTypeReference EntityNameHS
deriving Int -> SqlTypeExp -> ShowS
[SqlTypeExp] -> ShowS
SqlTypeExp -> String
(Int -> SqlTypeExp -> ShowS)
-> (SqlTypeExp -> String)
-> ([SqlTypeExp] -> ShowS)
-> Show SqlTypeExp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlTypeExp] -> ShowS
$cshowList :: [SqlTypeExp] -> ShowS
show :: SqlTypeExp -> String
$cshow :: SqlTypeExp -> String
showsPrec :: Int -> SqlTypeExp -> ShowS
$cshowsPrec :: Int -> SqlTypeExp -> ShowS
Show
liftSqlTypeExp :: SqlTypeExp -> Q Exp
liftSqlTypeExp :: SqlTypeExp -> Q Exp
liftSqlTypeExp SqlTypeExp
ste =
case SqlTypeExp
ste of
SqlType' SqlType
t ->
SqlType -> Q Exp
forall t. Lift t => t -> Q Exp
lift SqlType
t
SqlTypeExp FieldType
ftype -> do
let
typ :: Type
typ = FieldType -> Type
ftToType FieldType
ftype
mtyp :: Type
mtyp = Name -> Type
ConT ''Proxy Type -> Type -> Type
`AppT` Type
typ
typedNothing :: Exp
typedNothing = Exp -> Type -> Exp
SigE (Name -> Exp
ConE 'Proxy) Type
mtyp
Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'sqlType Exp -> Exp -> Exp
`AppE` Exp
typedNothing
SqlTypeReference EntityNameHS
entNameHs -> do
let
entNameId :: Name
entNameId :: Name
entNameId =
String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Id"
[| sqlType (Proxy :: Proxy $(conT entNameId)) |]
type EmbedEntityMap = M.Map EntityNameHS ()
constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap
constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap
constructEmbedEntityMap =
[(EntityNameHS, ())] -> EmbedEntityMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EntityNameHS, ())] -> EmbedEntityMap)
-> ([UnboundEntityDef] -> [(EntityNameHS, ())])
-> [UnboundEntityDef]
-> EmbedEntityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnboundEntityDef -> (EntityNameHS, ()))
-> [UnboundEntityDef] -> [(EntityNameHS, ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\UnboundEntityDef
ent ->
( EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent)
, ()
)
)
lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity :: Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity Map EntityNameHS a
allEntities FieldDef
field = do
EntityNameHS
entName <- Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldType -> Maybe Text
stripId (FieldDef -> FieldType
fieldType FieldDef
field)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (EntityNameHS -> Map EntityNameHS a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member EntityNameHS
entName Map EntityNameHS a
allEntities)
EntityNameHS -> Maybe EntityNameHS
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntityNameHS
entName
type EntityMap = M.Map EntityNameHS UnboundEntityDef
constructEntityMap :: [UnboundEntityDef] -> EntityMap
constructEntityMap :: [UnboundEntityDef] -> EntityMap
constructEntityMap =
[(EntityNameHS, UnboundEntityDef)] -> EntityMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EntityNameHS, UnboundEntityDef)] -> EntityMap)
-> ([UnboundEntityDef] -> [(EntityNameHS, UnboundEntityDef)])
-> [UnboundEntityDef]
-> EntityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnboundEntityDef -> (EntityNameHS, UnboundEntityDef))
-> [UnboundEntityDef] -> [(EntityNameHS, UnboundEntityDef)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\UnboundEntityDef
ent -> (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent), UnboundEntityDef
ent))
data FTTypeConDescr = FTKeyCon Text
deriving Int -> FTTypeConDescr -> ShowS
[FTTypeConDescr] -> ShowS
FTTypeConDescr -> String
(Int -> FTTypeConDescr -> ShowS)
-> (FTTypeConDescr -> String)
-> ([FTTypeConDescr] -> ShowS)
-> Show FTTypeConDescr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FTTypeConDescr] -> ShowS
$cshowList :: [FTTypeConDescr] -> ShowS
show :: FTTypeConDescr -> String
$cshow :: FTTypeConDescr -> String
showsPrec :: Int -> FTTypeConDescr -> ShowS
$cshowsPrec :: Int -> FTTypeConDescr -> ShowS
Show
mEmbedded
:: M.Map EntityNameHS a
-> FieldType
-> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded :: Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
_ (FTTypeCon Just{} Text
_) =
Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
ents (FTTypeCon Maybe Text
Nothing (Text -> EntityNameHS
EntityNameHS -> EntityNameHS
name)) =
Either (Maybe FTTypeConDescr) EntityNameHS
-> (a -> Either (Maybe FTTypeConDescr) EntityNameHS)
-> Maybe a
-> Either (Maybe FTTypeConDescr) EntityNameHS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing) (\a
_ -> EntityNameHS -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. b -> Either a b
Right EntityNameHS
name) (Maybe a -> Either (Maybe FTTypeConDescr) EntityNameHS)
-> Maybe a -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Map EntityNameHS a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
name Map EntityNameHS a
ents
mEmbedded Map EntityNameHS a
_ (FTTypePromoted Text
_) =
Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
ents (FTList FieldType
x) =
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
ents FieldType
x
mEmbedded Map EntityNameHS a
_ (FTApp (FTTypeCon Maybe Text
Nothing Text
"Key") (FTTypeCon Maybe Text
_ Text
a)) =
Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left (Maybe FTTypeConDescr
-> Either (Maybe FTTypeConDescr) EntityNameHS)
-> Maybe FTTypeConDescr
-> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. (a -> b) -> a -> b
$ FTTypeConDescr -> Maybe FTTypeConDescr
forall a. a -> Maybe a
Just (FTTypeConDescr -> Maybe FTTypeConDescr)
-> FTTypeConDescr -> Maybe FTTypeConDescr
forall a b. (a -> b) -> a -> b
$ Text -> FTTypeConDescr
FTKeyCon (Text -> FTTypeConDescr) -> Text -> FTTypeConDescr
forall a b. (a -> b) -> a -> b
$ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Id"
mEmbedded Map EntityNameHS a
_ (FTApp FieldType
_ FieldType
_) =
Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing
setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef
setEmbedField :: EntityNameHS -> Map EntityNameHS a -> FieldDef -> FieldDef
setEmbedField EntityNameHS
entName Map EntityNameHS a
allEntities FieldDef
field =
case FieldDef -> ReferenceDef
fieldReference FieldDef
field of
ReferenceDef
NoReference ->
ReferenceDef -> FieldDef -> FieldDef
setFieldReference ReferenceDef
ref FieldDef
field
ReferenceDef
_ ->
FieldDef
field
where
ref :: ReferenceDef
ref =
case Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
allEntities (FieldDef -> FieldType
fieldType FieldDef
field) of
Left Maybe FTTypeConDescr
_ -> ReferenceDef -> Maybe ReferenceDef -> ReferenceDef
forall a. a -> Maybe a -> a
fromMaybe ReferenceDef
NoReference (Maybe ReferenceDef -> ReferenceDef)
-> Maybe ReferenceDef -> ReferenceDef
forall a b. (a -> b) -> a -> b
$ do
EntityNameHS
refEntName <- Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
forall a. Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity Map EntityNameHS a
allEntities FieldDef
field
ReferenceDef -> Maybe ReferenceDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReferenceDef -> Maybe ReferenceDef)
-> ReferenceDef -> Maybe ReferenceDef
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> ReferenceDef
ForeignRef EntityNameHS
refEntName
Right EntityNameHS
em ->
if EntityNameHS
em EntityNameHS -> EntityNameHS -> Bool
forall a. Eq a => a -> a -> Bool
/= EntityNameHS
entName
then EntityNameHS -> ReferenceDef
EmbedRef EntityNameHS
em
else if UnboundFieldDef -> Bool
maybeNullable (FieldDef -> UnboundFieldDef
unbindFieldDef FieldDef
field)
then ReferenceDef
SelfReference
else case FieldDef -> FieldType
fieldType FieldDef
field of
FTList FieldType
_ -> ReferenceDef
SelfReference
FieldType
_ -> String -> ReferenceDef
forall a. HasCallStack => String -> a
error (String -> ReferenceDef) -> String -> ReferenceDef
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": a self reference must be a Maybe or List"
setFieldReference :: ReferenceDef -> FieldDef -> FieldDef
setFieldReference :: ReferenceDef -> FieldDef -> FieldDef
setFieldReference ReferenceDef
ref FieldDef
field = FieldDef
field { fieldReference :: ReferenceDef
fieldReference = ReferenceDef
ref }
mkPersist
:: MkPersistSettings
-> [UnboundEntityDef]
-> Q [Dec]
mkPersist :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
mkPersist MkPersistSettings
mps = MkPersistSettings -> [EntityDef] -> [UnboundEntityDef] -> Q [Dec]
mkPersistWith MkPersistSettings
mps []
mkPersistWith
:: MkPersistSettings
-> [EntityDef]
-> [UnboundEntityDef]
-> Q [Dec]
mkPersistWith :: MkPersistSettings -> [EntityDef] -> [UnboundEntityDef] -> Q [Dec]
mkPersistWith MkPersistSettings
mps [EntityDef]
preexistingEntities [UnboundEntityDef]
ents' = do
let
(EmbedEntityMap
embedEntityMap, [UnboundEntityDef]
predefs) =
[EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
preprocessUnboundDefs [EntityDef]
preexistingEntities [UnboundEntityDef]
ents'
allEnts :: [UnboundEntityDef]
allEnts =
[EntityDef] -> [UnboundEntityDef] -> [UnboundEntityDef]
embedEntityDefs [EntityDef]
preexistingEntities
([UnboundEntityDef] -> [UnboundEntityDef])
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> UnboundEntityDef)
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields MkPersistSettings
mps)
([UnboundEntityDef] -> [UnboundEntityDef])
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> a -> b
$ [UnboundEntityDef]
predefs
entityMap :: EntityMap
entityMap =
[UnboundEntityDef] -> EntityMap
constructEntityMap [UnboundEntityDef]
allEnts
preexistingSet :: Set EntityNameHS
preexistingSet =
[EntityNameHS] -> Set EntityNameHS
forall a. Ord a => [a] -> Set a
Set.fromList ([EntityNameHS] -> Set EntityNameHS)
-> [EntityNameHS] -> Set EntityNameHS
forall a b. (a -> b) -> a -> b
$ (EntityDef -> EntityNameHS) -> [EntityDef] -> [EntityNameHS]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> EntityNameHS
getEntityHaskellName [EntityDef]
preexistingEntities
newEnts :: [UnboundEntityDef]
newEnts =
(UnboundEntityDef -> Bool)
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a. (a -> Bool) -> [a] -> [a]
filter
(\UnboundEntityDef
e -> UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
e EntityNameHS -> Set EntityNameHS -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set EntityNameHS
preexistingSet)
[UnboundEntityDef]
allEnts
[UnboundEntityDef]
ents <- (UnboundEntityDef -> Q Bool)
-> [UnboundEntityDef] -> Q [UnboundEntityDef]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM UnboundEntityDef -> Q Bool
shouldGenerateCode [UnboundEntityDef]
newEnts
[[Extension]] -> Q ()
requireExtensions
[ [Extension
TypeFamilies], [Extension
GADTs, Extension
ExistentialQuantification]
, [Extension
DerivingStrategies], [Extension
GeneralizedNewtypeDeriving], [Extension
StandaloneDeriving]
, [Extension
UndecidableInstances], [Extension
DataKinds], [Extension
FlexibleInstances]
]
[Dec]
persistFieldDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps) [UnboundEntityDef]
ents
[Dec]
entityDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (EmbedEntityMap
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
forall a.
Map EntityNameHS a
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkEntity EmbedEntityMap
embedEntityMap EntityMap
entityMap MkPersistSettings
mps) [UnboundEntityDef]
ents
[Dec]
jsonDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON MkPersistSettings
mps) [UnboundEntityDef]
ents
[Dec]
uniqueKeyInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances MkPersistSettings
mps) [UnboundEntityDef]
ents
[Dec]
symbolToFieldInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkSymbolToFieldInstances MkPersistSettings
mps EntityMap
entityMap) [UnboundEntityDef]
ents
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat
[ [Dec]
persistFieldDecs
, [Dec]
entityDecs
, [Dec]
jsonDecs
, [Dec]
uniqueKeyInstances
, [Dec]
symbolToFieldInstances
]
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode UnboundEntityDef
ed = do
Maybe Name
mtyp <- String -> Q (Maybe Name)
lookupTypeName String
entityName
case Maybe Name
mtyp of
Maybe Name
Nothing -> do
Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just Name
typeName -> do
Bool
instanceExists <- Name -> [Type] -> Q Bool
isInstance ''PersistEntity [Name -> Type
ConT Name
typeName]
Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bool
not Bool
instanceExists)
where
entityName :: String
entityName =
Text -> String
T.unpack (Text -> String)
-> (UnboundEntityDef -> Text) -> UnboundEntityDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
getEntityHaskellName (EntityDef -> EntityNameHS)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef (UnboundEntityDef -> String) -> UnboundEntityDef -> String
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef
ed
overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overEntityDef EntityDef -> EntityDef
f UnboundEntityDef
ued = UnboundEntityDef
ued { unboundEntityDef :: EntityDef
unboundEntityDef = EntityDef -> EntityDef
f (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ued) }
setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields MkPersistSettings
mps UnboundEntityDef
ued
| UnboundEntityDef -> Bool
defaultIdType UnboundEntityDef
ued =
(EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overEntityDef
(EntityIdDef -> EntityDef -> EntityDef
setEntityIdDef (ImplicitIdDef -> EntityIdDef -> EntityIdDef
setToMpsDefault (MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef MkPersistSettings
mps) (EntityDef -> EntityIdDef
getEntityId EntityDef
ed)))
UnboundEntityDef
ued
| Bool
otherwise =
UnboundEntityDef
ued
where
ed :: EntityDef
ed =
UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ued
setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef
setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef
setToMpsDefault ImplicitIdDef
iid (EntityIdField FieldDef
fd) =
FieldDef -> EntityIdDef
EntityIdField FieldDef
fd
{ fieldType :: FieldType
fieldType =
ImplicitIdDef -> EntityNameHS -> FieldType
iidFieldType ImplicitIdDef
iid (EntityDef -> EntityNameHS
getEntityHaskellName EntityDef
ed)
, fieldSqlType :: SqlType
fieldSqlType =
ImplicitIdDef -> SqlType
iidFieldSqlType ImplicitIdDef
iid
, fieldAttrs :: [FieldAttr]
fieldAttrs =
let
def :: [FieldAttr]
def =
Maybe FieldAttr -> [FieldAttr]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Text -> FieldAttr
FieldAttrDefault (Text -> FieldAttr) -> Maybe Text -> Maybe FieldAttr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Text
iidDefault ImplicitIdDef
iid)
maxlen :: [FieldAttr]
maxlen =
Maybe FieldAttr -> [FieldAttr]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Integer -> FieldAttr
FieldAttrMaxlen (Integer -> FieldAttr) -> Maybe Integer -> Maybe FieldAttr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Integer
iidMaxLen ImplicitIdDef
iid)
in
[FieldAttr]
def [FieldAttr] -> [FieldAttr] -> [FieldAttr]
forall a. Semigroup a => a -> a -> a
<> [FieldAttr]
maxlen [FieldAttr] -> [FieldAttr] -> [FieldAttr]
forall a. Semigroup a => a -> a -> a
<> FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
, fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn =
Bool
True
}
setToMpsDefault ImplicitIdDef
_ EntityIdDef
x =
EntityIdDef
x
fixEntityDef :: UnboundEntityDef -> UnboundEntityDef
fixEntityDef :: UnboundEntityDef -> UnboundEntityDef
fixEntityDef UnboundEntityDef
ued =
UnboundEntityDef
ued
{ unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
(UnboundFieldDef -> Bool) -> [UnboundFieldDef] -> [UnboundFieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter UnboundFieldDef -> Bool
isHaskellUnboundField (UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields UnboundEntityDef
ued)
}
data MkPersistSettings = MkPersistSettings
{ MkPersistSettings -> Type
mpsBackend :: Type
, MkPersistSettings -> Bool
mpsGeneric :: Bool
, MkPersistSettings -> Bool
mpsPrefixFields :: Bool
, MkPersistSettings -> Text -> Text -> Text
mpsFieldLabelModifier :: Text -> Text -> Text
, MkPersistSettings -> Text -> Text -> Text
mpsConstraintLabelModifier :: Text -> Text -> Text
, MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON :: Maybe EntityJSON
, MkPersistSettings -> Bool
mpsGenerateLenses :: Bool
, MkPersistSettings -> [Name]
mpsDeriveInstances :: [Name]
, MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef :: ImplicitIdDef
}
{-# 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" #-}
setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings
setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings
setImplicitIdDef ImplicitIdDef
iid MkPersistSettings
mps =
MkPersistSettings
mps { mpsImplicitIdDef :: ImplicitIdDef
mpsImplicitIdDef = ImplicitIdDef
iid }
getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType = do
ImplicitIdDef
idDef <- MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef
Bool
isGeneric <- MkPersistSettings -> Bool
mpsGeneric
Type
backendTy <- MkPersistSettings -> Type
mpsBackend
Type -> MkPersistSettings -> Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> MkPersistSettings -> Type)
-> Type -> MkPersistSettings -> Type
forall a b. (a -> b) -> a -> b
$ ImplicitIdDef -> Bool -> Type -> Type
iidType ImplicitIdDef
idDef Bool
isGeneric Type
backendTy
data EntityJSON = EntityJSON
{ EntityJSON -> Name
entityToJSON :: Name
, EntityJSON -> Name
entityFromJSON :: Name
}
mkPersistSettings
:: Type
-> MkPersistSettings
mkPersistSettings :: Type -> MkPersistSettings
mkPersistSettings Type
backend = MkPersistSettings :: Type
-> Bool
-> Bool
-> (Text -> Text -> Text)
-> (Text -> Text -> Text)
-> Maybe EntityJSON
-> Bool
-> [Name]
-> ImplicitIdDef
-> MkPersistSettings
MkPersistSettings
{ mpsBackend :: Type
mpsBackend = Type
backend
, mpsGeneric :: Bool
mpsGeneric = Bool
False
, mpsPrefixFields :: Bool
mpsPrefixFields = Bool
True
, mpsFieldLabelModifier :: Text -> Text -> Text
mpsFieldLabelModifier = Text -> Text -> Text
forall m. Monoid m => m -> m -> m
(++)
, mpsConstraintLabelModifier :: Text -> Text -> Text
mpsConstraintLabelModifier = Text -> Text -> Text
forall m. Monoid m => m -> m -> m
(++)
, mpsEntityJSON :: Maybe EntityJSON
mpsEntityJSON = EntityJSON -> Maybe EntityJSON
forall a. a -> Maybe a
Just EntityJSON :: Name -> Name -> EntityJSON
EntityJSON
{ entityToJSON :: Name
entityToJSON = 'entityIdToJSON
, entityFromJSON :: Name
entityFromJSON = 'entityIdFromJSON
}
, mpsGenerateLenses :: Bool
mpsGenerateLenses = Bool
False
, mpsDeriveInstances :: [Name]
mpsDeriveInstances = []
, mpsImplicitIdDef :: ImplicitIdDef
mpsImplicitIdDef =
ImplicitIdDef
autoIncrementingInteger
}
sqlSettings :: MkPersistSettings
sqlSettings :: MkPersistSettings
sqlSettings = Type -> MkPersistSettings
mkPersistSettings (Type -> MkPersistSettings) -> Type -> MkPersistSettings
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''SqlBackend
lowerFirst :: Text -> Text
lowerFirst :: Text -> Text
lowerFirst Text
t =
case Text -> Maybe (Char, Text)
uncons Text
t of
Just (Char
a, Text
b) -> Char -> Text -> Text
cons (Char -> Char
toLower Char
a) Text
b
Maybe (Char, Text)
Nothing -> Text
t
upperFirst :: Text -> Text
upperFirst :: Text -> Text
upperFirst Text
t =
case Text -> Maybe (Char, Text)
uncons Text
t of
Just (Char
a, Text
b) -> Char -> Text -> Text
cons (Char -> Char
toUpper Char
a) Text
b
Maybe (Char, Text)
Nothing -> Text
t
dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec
dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec
dataTypeDec MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef = do
let
names :: [Name]
names =
MkPersistSettings -> UnboundEntityDef -> [Name]
mkEntityDefDeriveNames MkPersistSettings
mps UnboundEntityDef
entDef
let ([Name]
stocks, [Name]
anyclasses) = [Either Name Name] -> ([Name], [Name])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((Name -> Either Name Name) -> [Name] -> [Either Name Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Either Name Name
stratFor [Name]
names)
let stockDerives :: [DerivClause]
stockDerives = do
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
stocks))
DerivClause -> [DerivClause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) ((Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
ConT [Name]
stocks))
anyclassDerives :: [DerivClause]
anyclassDerives = do
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
anyclasses))
DerivClause -> [DerivClause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
AnyclassStrategy) ((Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
ConT [Name]
anyclasses))
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DerivClause] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DerivClause]
anyclassDerives) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
[[Extension]] -> Q ()
requireExtensions [[Extension
DeriveAnyClass]]
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
nameFinal [TyVarBndr]
paramsFinal
Maybe Type
forall a. Maybe a
Nothing
[Con]
constrs
([DerivClause]
stockDerives [DerivClause] -> [DerivClause] -> [DerivClause]
forall a. Semigroup a => a -> a -> a
<> [DerivClause]
anyclassDerives)
where
stratFor :: Name -> Either Name Name
stratFor Name
n =
if Name
n Name -> Set Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set Name
stockClasses then
Name -> Either Name Name
forall a b. a -> Either a b
Left Name
n
else
Name -> Either Name Name
forall a b. b -> Either a b
Right Name
n
stockClasses :: Set Name
stockClasses =
[Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ((String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName
[ String
"Eq", String
"Ord", String
"Show", String
"Read", String
"Bounded", String
"Enum", String
"Ix", String
"Generic", String
"Data", String
"Typeable"
] [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable
]
)
(Name
nameFinal, [TyVarBndr]
paramsFinal)
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
( UnboundEntityDef -> Name
mkEntityDefGenericName UnboundEntityDef
entDef
, [ Name -> TyVarBndr
mkPlainTV Name
backendName
]
)
| Bool
otherwise =
(UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef, [])
cols :: [VarBangType]
cols :: [VarBangType]
cols = do
UnboundFieldDef
fieldDef <- UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
let
recordName :: Name
recordName =
MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef
strictness :: Bang
strictness =
if UnboundFieldDef -> Bool
unboundFieldStrict UnboundFieldDef
fieldDef
then Bang
isStrict
else Bang
notStrict
fieldIdType :: Type
fieldIdType =
MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing
VarBangType -> [VarBangType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
recordName, Bang
strictness, Type
fieldIdType)
constrs :: [Con]
constrs
| UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef = (UnboundFieldDef -> Con) -> [UnboundFieldDef] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundFieldDef -> Con
sumCon ([UnboundFieldDef] -> [Con]) -> [UnboundFieldDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
| Bool
otherwise = [Name -> [VarBangType] -> Con
RecC (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef) [VarBangType]
cols]
sumCon :: UnboundFieldDef -> Con
sumCon UnboundFieldDef
fieldDef = Name -> [BangType] -> Con
NormalC
(MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef)
[(Bang
notStrict, MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing)]
uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
uniqueTypeDec MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef =
[Type]
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD
[]
#if MIN_VERSION_template_haskell(2,15,0)
Maybe [TyVarBndr]
forall a. Maybe a
Nothing
(Type -> Type -> Type
AppT (Name -> Type
ConT ''Unique) (MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef) Type
backendT))
#else
''Unique
[genericDataType mps (getUnboundEntityNameHS entDef) backendT]
#endif
Maybe Type
forall a. Maybe a
Nothing
((UniqueDef -> Con) -> [UniqueDef] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MkPersistSettings
-> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
mkUnique MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef) ([UniqueDef] -> [Con]) -> [UniqueDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef))
[]
mkUnique :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
mkUnique :: MkPersistSettings
-> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
mkUnique MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
fields [Text]
attrs) =
Name -> [BangType] -> Con
NormalC (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
constr) ([BangType] -> Con) -> [BangType] -> Con
forall a b. (a -> b) -> a -> b
$ NonEmpty BangType -> [BangType]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty BangType
types
where
types :: NonEmpty BangType
types =
(ForeignFieldDef -> BangType)
-> NonEmpty ForeignFieldDef -> NonEmpty BangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UnboundFieldDef, IsNullable) -> BangType
go ((UnboundFieldDef, IsNullable) -> BangType)
-> (ForeignFieldDef -> (UnboundFieldDef, IsNullable))
-> ForeignFieldDef
-> BangType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable))
-> [UnboundFieldDef] -> Text -> (UnboundFieldDef, IsNullable)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
lookup3 (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef) (Text -> (UnboundFieldDef, IsNullable))
-> (ForeignFieldDef -> Text)
-> ForeignFieldDef
-> (UnboundFieldDef, IsNullable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> (ForeignFieldDef -> FieldNameHS) -> ForeignFieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignFieldDef -> FieldNameHS
forall a b. (a, b) -> a
fst) NonEmpty ForeignFieldDef
fields
force :: Bool
force = Text
"!force" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
attrs
go :: (UnboundFieldDef, IsNullable) -> (Strict, Type)
go :: (UnboundFieldDef, IsNullable) -> BangType
go (UnboundFieldDef
_, Nullable WhyNullable
_) | Bool -> Bool
not Bool
force = String -> BangType
forall a. HasCallStack => String -> a
error String
nullErrMsg
go (UnboundFieldDef
fd, IsNullable
y) = (Bang
notStrict, MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fd Maybe Name
forall a. Maybe a
Nothing (IsNullable -> Maybe IsNullable
forall a. a -> Maybe a
Just IsNullable
y))
lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
lookup3 Text
s [] =
String -> (UnboundFieldDef, IsNullable)
forall a. HasCallStack => String -> a
error (String -> (UnboundFieldDef, IsNullable))
-> String -> (UnboundFieldDef, IsNullable)
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Column not found: " Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
s Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
" in unique " Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ ConstraintNameHS -> Text
unConstraintNameHS ConstraintNameHS
constr
lookup3 Text
x (UnboundFieldDef
fd:[UnboundFieldDef]
rest)
| Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== FieldNameHS -> Text
unFieldNameHS (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fd) =
(UnboundFieldDef
fd, UnboundFieldDef -> IsNullable
isUnboundFieldNullable UnboundFieldDef
fd)
| Bool
otherwise =
Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
lookup3 Text
x [UnboundFieldDef]
rest
nullErrMsg :: String
nullErrMsg =
[String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"Error: By default we disallow NULLables in an uniqueness "
, String
"constraint. The semantics of how NULL interacts with those "
, String
"constraints is non-trivial: two NULL values are not "
, String
"considered equal for the purposes of an uniqueness "
, String
"constraint. If you understand this feature, it is possible "
, String
"to use it your advantage. *** Use a \"!force\" attribute "
, String
"on the end of the line that defines your uniqueness "
, String
"constraint in order to disable this check. ***" ]
maybeIdType
:: MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType :: MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef Maybe Name
mbackend Maybe IsNullable
mnull =
Bool -> Type -> Type
maybeTyp Bool
mayNullable Type
idType
where
mayNullable :: Bool
mayNullable =
case Maybe IsNullable
mnull of
Just (Nullable WhyNullable
ByMaybeAttr) ->
Bool
True
Maybe IsNullable
_ ->
UnboundFieldDef -> Bool
maybeNullable UnboundFieldDef
fieldDef
idType :: Type
idType =
Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (FieldType -> Type
ftToType (FieldType -> Type) -> FieldType -> Type
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
fieldDef) (Maybe Type -> Type) -> Maybe Type -> Type
forall a b. (a -> b) -> a -> b
$ do
EntityNameHS
typ <- EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
fieldDef
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps))
Type -> Maybe Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$
Name -> Type
ConT ''Key
Type -> Type -> Type
`AppT` MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
typ (Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
backendName Maybe Name
mbackend)
_removeIdFromTypeSuffix :: Name -> Type
_removeIdFromTypeSuffix :: Name -> Type
_removeIdFromTypeSuffix oldName :: Name
oldName@(Name (OccName String
nm) NameFlavour
nameFlavor) =
case Text -> Text -> Maybe Text
stripSuffix Text
"Id" (String -> Text
T.pack String
nm) of
Maybe Text
Nothing ->
Name -> Type
ConT Name
oldName
Just Text
name ->
Name -> Type
ConT ''Key
Type -> Type -> Type
`AppT` do
Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ OccName -> NameFlavour -> Name
Name (String -> OccName
OccName (Text -> String
T.unpack Text
name)) NameFlavour
nameFlavor
_lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type)
_lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type)
_lookupReferencedTable EntityMap
em Text
fieldTypeText = do
let
mmodelIdString :: Maybe String
mmodelIdString = do
Text
fieldTypeNoId <- Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
fieldTypeText
UnboundEntityDef
_ <- EntityNameHS -> EntityMap -> Maybe UnboundEntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> EntityNameHS
EntityNameHS Text
fieldTypeNoId) EntityMap
em
String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
fieldTypeText)
case Maybe String
mmodelIdString of
Maybe String
Nothing ->
Maybe Type -> Q (Maybe Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Type
forall a. Maybe a
Nothing
Just String
modelIdString -> do
Maybe Name
mIdName <- String -> Q (Maybe Name)
lookupTypeName String
modelIdString
Maybe Type -> Q (Maybe Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Type -> Q (Maybe Type)) -> Maybe Type -> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ (Name -> Type) -> Maybe Name -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
_removeIdFromTypeSuffix Maybe Name
mIdName
_fieldNameEndsWithId :: UnboundFieldDef -> Maybe String
_fieldNameEndsWithId :: UnboundFieldDef -> Maybe String
_fieldNameEndsWithId UnboundFieldDef
ufd = FieldType -> Maybe String
go (UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
ufd)
where
go :: FieldType -> Maybe String
go = \case
FTTypeCon Maybe Text
mmodule Text
name -> do
Text
a <- Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
name
String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ case Maybe Text
mmodule of
Maybe Text
Nothing ->
Text
""
Just Text
m ->
[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
m, Text
"."]
, Text
a
, Text
"Id"
]
FieldType
_ ->
Maybe String
forall a. Maybe a
Nothing
backendDataType :: MkPersistSettings -> Type
backendDataType :: MkPersistSettings -> Type
backendDataType MkPersistSettings
mps
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps = Type
backendT
| Bool
otherwise = MkPersistSettings -> Type
mpsBackend MkPersistSettings
mps
genericDataType
:: MkPersistSettings
-> EntityNameHS
-> Type
-> Type
genericDataType :: MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
name Type
backend
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
Name -> Type
ConT (EntityNameHS -> Name
mkEntityNameHSGenericName EntityNameHS
name) Type -> Type -> Type
`AppT` Type
backend
| Bool
otherwise =
Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Name
mkEntityNameHSName EntityNameHS
name
degen :: [Clause] -> [Clause]
degen :: [Clause] -> [Clause]
degen [] =
let err :: Exp
err = Name -> Exp
VarE 'error Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL
String
"Degenerate case, should never happen")
in [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
err]
degen [Clause]
x = [Clause]
x
mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkToPersistFields MkPersistSettings
mps UnboundEntityDef
ed = do
let isSum :: Bool
isSum = UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
ed
fields :: [UnboundFieldDef]
fields = UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ed
[Clause]
clauses <-
if Bool
isSum
then [Q Clause] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Clause] -> Q [Clause]) -> [Q Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ (UnboundFieldDef -> Int -> Q Clause)
-> [UnboundFieldDef] -> [Int] -> [Q Clause]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith UnboundFieldDef -> Int -> Q Clause
goSum [UnboundFieldDef]
fields [Int
1..]
else (Clause -> [Clause]) -> Q Clause -> Q [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return Q Clause
go
Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'toPersistFields [Clause]
clauses
where
go :: Q Clause
go :: Q Clause
go = do
[Name]
xs <- [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Q Name -> [Q Name]
forall a. Int -> a -> [a]
replicate Int
fieldCount (Q Name -> [Q Name]) -> Q Name -> [Q Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x"
let name :: Name
name = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ed
pat :: Pat
pat = Name -> [Pat] -> Pat
conp Name
name ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
xs
Exp
sp <- [|SomePersistField|]
let bod :: Exp
bod = [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE Exp
sp (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] Exp
bod
fieldCount :: Int
fieldCount = [UnboundFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ed)
goSum :: UnboundFieldDef -> Int -> Q Clause
goSum :: UnboundFieldDef -> Int -> Q Clause
goSum UnboundFieldDef
fieldDef Int
idx = do
let name :: Name
name = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
ed UnboundFieldDef
fieldDef
Exp
enull <- [|SomePersistField PersistNull|]
let beforeCount :: Int
beforeCount = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
afterCount :: Int
afterCount = Int
fieldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
idx
before :: [Exp]
before = Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
beforeCount Exp
enull
after :: [Exp]
after = Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
afterCount Exp
enull
Name
x <- String -> Q Name
newName String
"x"
Exp
sp <- [|SomePersistField|]
let body :: Exp
body = [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ [[Exp]] -> [Exp]
forall a. Monoid a => [a] -> a
mconcat
[ [Exp]
before
, [Exp
sp Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x]
, [Exp]
after
]
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Name -> [Pat] -> Pat
conp Name
name [Name -> Pat
VarP Name
x]] Exp
body
mkToFieldNames :: [UniqueDef] -> Q Dec
mkToFieldNames :: [UniqueDef] -> Q Dec
mkToFieldNames [UniqueDef]
pairs = do
[Clause]
pairs' <- (UniqueDef -> Q Clause) -> [UniqueDef] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UniqueDef -> Q Clause
go [UniqueDef]
pairs
Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueToFieldNames ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [Clause] -> [Clause]
degen [Clause]
pairs'
where
go :: UniqueDef -> Q Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
names [Text]
_) = do
Exp
names' <- NonEmpty ForeignFieldDef -> Q Exp
forall t. Lift t => t -> Q Exp
lift NonEmpty ForeignFieldDef
names
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
[Pat] -> Exp -> Clause
normalClause
[Name -> [FieldPat] -> Pat
RecP (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
constr) []]
Exp
names'
mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues [UniqueDef]
pairs = do
[Clause]
pairs' <- (UniqueDef -> Q Clause) -> [UniqueDef] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UniqueDef -> Q Clause
go [UniqueDef]
pairs
Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueToValues ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [Clause] -> [Clause]
degen [Clause]
pairs'
where
go :: UniqueDef -> Q Clause
go :: UniqueDef -> Q Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
names [Text]
_) = do
NonEmpty Name
xs <- (ForeignFieldDef -> Q Name)
-> NonEmpty ForeignFieldDef -> Q (NonEmpty Name)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> ForeignFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> ForeignFieldDef -> Q Name)
-> Q Name -> ForeignFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") NonEmpty ForeignFieldDef
names
let pat :: Pat
pat = Name -> [Pat] -> Pat
conp (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
constr) ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP ([Name] -> [Pat]) -> [Name] -> [Pat]
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
Exp
tpv <- [|toPersistValue|]
let bod :: Exp
bod = [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE Exp
tpv (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) ([Name] -> [Exp]) -> [Name] -> [Exp]
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] Exp
bod
isNotNull :: PersistValue -> Bool
isNotNull :: PersistValue -> Bool
isNotNull PersistValue
PersistNull = Bool
False
isNotNull PersistValue
_ = Bool
True
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft a -> c
_ (Right b
r) = b -> Either c b
forall a b. b -> Either a b
Right b
r
mapLeft a -> c
f (Left a
l) = c -> Either c b
forall a b. a -> Either a b
Left (a -> c
f a
l)
mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues MkPersistSettings
mps UnboundEntityDef
entDef
| UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef = do
Exp
nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
[Clause]
clauses <- [UnboundFieldDef] -> [UnboundFieldDef] -> Q [Clause]
mkClauses [] ([UnboundFieldDef] -> Q [Clause])
-> [UnboundFieldDef] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
[Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Clause] -> Q [Clause]) -> [Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ [Clause]
clauses [Clause] -> [Clause] -> [Clause]
forall m. Monoid m => m -> m -> m
`mappend` [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
nothing]
| Bool
otherwise =
UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues UnboundEntityDef
entDef Text
"fromPersistValues" Exp
entE
([FieldNameHS] -> Q [Clause]) -> [FieldNameHS] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ (UnboundFieldDef -> FieldNameHS)
-> [UnboundFieldDef] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundFieldDef -> FieldNameHS
unboundFieldNameHS
([UnboundFieldDef] -> [FieldNameHS])
-> [UnboundFieldDef] -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ (UnboundFieldDef -> Bool) -> [UnboundFieldDef] -> [UnboundFieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter UnboundFieldDef -> Bool
isHaskellUnboundField
([UnboundFieldDef] -> [UnboundFieldDef])
-> [UnboundFieldDef] -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
where
entName :: Text
entName = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef
mkClauses :: [UnboundFieldDef] -> [UnboundFieldDef] -> Q [Clause]
mkClauses [UnboundFieldDef]
_ [] = [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkClauses [UnboundFieldDef]
before (UnboundFieldDef
field:[UnboundFieldDef]
after) = do
Name
x <- String -> Q Name
newName String
"x"
let null' :: Pat
null' = Name -> [Pat] -> Pat
conp 'PersistNull []
pat :: Pat
pat = [Pat] -> Pat
ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ [[Pat]] -> [Pat]
forall a. Monoid a => [a] -> a
mconcat
[ (UnboundFieldDef -> Pat) -> [UnboundFieldDef] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pat -> UnboundFieldDef -> Pat
forall a b. a -> b -> a
const Pat
null') [UnboundFieldDef]
before
, [Name -> Pat
VarP Name
x]
, (UnboundFieldDef -> Pat) -> [UnboundFieldDef] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pat -> UnboundFieldDef -> Pat
forall a b. a -> b -> a
const Pat
null') [UnboundFieldDef]
after
]
constr :: Exp
constr = Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
field
Exp
fs <- [|fromPersistValue $(return $ VarE x)|]
let guard' :: Guard
guard' = Exp -> Guard
NormalG (Exp -> Guard) -> Exp -> Guard
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'isNotNull Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x
let clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] ([(Guard, Exp)] -> Body
GuardedB [(Guard
guard', Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
constr) Exp
fmapE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
fs))]) []
[Clause]
clauses <- [UnboundFieldDef] -> [UnboundFieldDef] -> Q [Clause]
mkClauses (UnboundFieldDef
field UnboundFieldDef -> [UnboundFieldDef] -> [UnboundFieldDef]
forall a. a -> [a] -> [a]
: [UnboundFieldDef]
before) [UnboundFieldDef]
after
[Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Clause] -> Q [Clause]) -> [Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ Clause
clause Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: [Clause]
clauses
entE :: Exp
entE = UnboundEntityDef -> Exp
entityDefConE UnboundEntityDef
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 :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lensPTH s -> a
sa s -> b -> t
sbt a -> f b
afb s
s = (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s -> b -> t
sbt s
s) (a -> f b
afb (a -> f b) -> a -> f b
forall a b. (a -> b) -> a -> b
$ s -> a
sa s
s)
fmapE :: Exp
fmapE :: Exp
fmapE = Name -> Exp
VarE 'fmap
unboundEntitySum :: UnboundEntityDef -> Bool
unboundEntitySum :: UnboundEntityDef -> Bool
unboundEntitySum = EntityDef -> Bool
entitySum (EntityDef -> Bool)
-> (UnboundEntityDef -> EntityDef) -> UnboundEntityDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef
fieldSel :: Name -> Name -> Exp
fieldSel :: Name -> Name -> Exp
fieldSel Name
conName Name
fieldName
= [Pat] -> Exp -> Exp
LamE [Name -> [FieldPat] -> Pat
RecP Name
conName [(Name
fieldName, Name -> Pat
VarP Name
xName)]] (Name -> Exp
VarE Name
xName)
where
xName :: Name
xName = String -> Name
mkName String
"x"
fieldUpd :: Name
-> [Name]
-> Exp
-> Name
-> Exp
-> Exp
fieldUpd :: Name -> [Name] -> Exp -> Name -> Exp -> Exp
fieldUpd Name
con [Name]
names Exp
record Name
name Exp
new = Exp -> [Match] -> Exp
CaseE Exp
record
[ Pat -> Body -> [Dec] -> Match
Match (Name -> [FieldPat] -> Pat
RecP Name
con [FieldPat]
pats) (Exp -> Body
NormalB Exp
body) []]
where
body :: Exp
body = Name -> [FieldExp] -> Exp
RecConE Name
con
[ if Name
k Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name then (Name
name, Exp
new) else (Name
k, Name -> Exp
VarE Name
k)
| Name
k <- [Name]
names
]
pats :: [FieldPat]
pats = [ (Name
k, Name -> Pat
VarP Name
k) | Name
k <- [Name]
names, Name
k Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
name]
mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
mkLensClauses MkPersistSettings
mps UnboundEntityDef
entDef Type
genDataType = do
Exp
lens' <- [|lensPTH|]
Exp
getId <- [|entityKey|]
Exp
setId <- [|\(Entity _ value) key -> Entity key value|]
Exp
getVal <- [|entityVal|]
Exp
dot <- [|(.)|]
Name
keyVar <- String -> Q Name
newName String
"key"
Name
valName <- String -> Q Name
newName String
"value"
Name
xName <- String -> Q Name
newName String
"x"
let idClause :: Clause
idClause = [Pat] -> Exp -> Clause
normalClause
[Name -> [Pat] -> Pat
conp (UnboundEntityDef -> Name
keyIdName UnboundEntityDef
entDef) []]
(Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getId Exp -> Exp -> Exp
`AppE` Exp
setId)
[Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Clause] -> Q [Clause]) -> [Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ Clause
idClause Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: if UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef
then (UnboundFieldDef -> Clause) -> [UnboundFieldDef] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Name -> Name -> Name -> UnboundFieldDef -> Clause
toSumClause Exp
lens' Name
keyVar Name
valName Name
xName) (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef)
else (UnboundFieldDef -> Name -> Clause)
-> [UnboundFieldDef] -> [Name] -> [Clause]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Exp
-> Exp
-> Exp
-> Name
-> Name
-> Name
-> UnboundFieldDef
-> Name
-> Clause
toClause Exp
lens' Exp
getVal Exp
dot Name
keyVar Name
valName Name
xName) (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef) [Name]
fieldNames
where
fieldNames :: [Name]
fieldNames = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
entDef (UnboundFieldDef -> Name) -> [UnboundFieldDef] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
toClause :: Exp
-> Exp
-> Exp
-> Name
-> Name
-> Name
-> UnboundFieldDef
-> Name
-> Clause
toClause Exp
lens' Exp
getVal Exp
dot Name
keyVar Name
valName Name
xName UnboundFieldDef
fieldDef Name
fieldName = [Pat] -> Exp -> Clause
normalClause
[Name -> [Pat] -> Pat
conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) []]
(Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getter Exp -> Exp -> Exp
`AppE` Exp
setter)
where
defName :: Name
defName = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef
getter :: Exp
getter = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Exp
fieldSel Name
defName Name
fieldName) Exp
dot (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
getVal)
setter :: Exp
setter = [Pat] -> Exp -> Exp
LamE
[ Name -> [Pat] -> Pat
conp 'Entity [Name -> Pat
VarP Name
keyVar, Name -> Pat
VarP Name
valName]
, Name -> Pat
VarP Name
xName
]
(Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Entity Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
keyVar
Exp -> Exp -> Exp
`AppE` Name -> [Name] -> Exp -> Name -> Exp -> Exp
fieldUpd Name
defName [Name]
fieldNames (Name -> Exp
VarE Name
valName) Name
fieldName (Name -> Exp
VarE Name
xName)
toSumClause :: Exp -> Name -> Name -> Name -> UnboundFieldDef -> Clause
toSumClause Exp
lens' Name
keyVar Name
valName Name
xName UnboundFieldDef
fieldDef = [Pat] -> Exp -> Clause
normalClause
[Name -> [Pat] -> Pat
conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) []]
(Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getter Exp -> Exp -> Exp
`AppE` Exp
setter)
where
emptyMatch :: Match
emptyMatch = Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'error Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
"Tried to use fieldLens on a Sum type")) []
getter :: Exp
getter = [Pat] -> Exp -> Exp
LamE
[ Name -> [Pat] -> Pat
conp 'Entity [Pat
WildP, Name -> Pat
VarP Name
valName]
] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
valName)
([Match] -> Exp) -> [Match] -> Exp
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) [Name -> Pat
VarP Name
xName]) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
xName) []
Match -> [Match] -> [Match]
forall a. a -> [a] -> [a]
: if [UnboundFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then [Match
emptyMatch] else []
setter :: Exp
setter = [Pat] -> Exp -> Exp
LamE
[ Name -> [Pat] -> Pat
conp 'Entity [Name -> Pat
VarP Name
keyVar, Pat
WildP]
, Name -> Pat
VarP Name
xName
]
(Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Entity Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
keyVar Exp -> Exp -> Exp
`AppE` (Name -> Exp
ConE (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
xName)
mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec MkPersistSettings
mps UnboundEntityDef
entDef = do
([Dec]
instDecs, [Name]
i) <-
if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
then if Bool -> Bool
not Bool
useNewtype
then do [Dec]
pfDec <- Q [Dec]
pfInstD
([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
pfDec, [Name] -> [Name]
supplement [''Generic])
else do [Dec]
gi <- Q [Dec]
genericNewtypeInstances
([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
gi, [Name] -> [Name]
supplement [])
else if Bool -> Bool
not Bool
useNewtype
then do [Dec]
pfDec <- Q [Dec]
pfInstD
([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
pfDec, [Name] -> [Name]
supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])
else do
let allInstances :: [Name]
allInstances = [Name] -> [Name]
supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
if Bool
customKeyType
then ([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Name]
allInstances)
else do
[Dec]
bi <- Q [Dec]
backendKeyI
([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
bi, [Name]
allInstances)
Q ()
requirePersistentExtensions
let alwaysStockStrategyTypeclasses :: [Name]
alwaysStockStrategyTypeclasses = [''Show, ''Read]
deriveClauses :: [DerivClause]
deriveClauses = (Name -> DerivClause) -> [Name] -> [DerivClause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
typeclass ->
if (Bool -> Bool
not Bool
useNewtype Bool -> Bool -> Bool
|| Name
typeclass Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
alwaysStockStrategyTypeclasses)
then Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) [(Name -> Type
ConT Name
typeclass)]
else Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
NewtypeStrategy) [(Name -> Type
ConT Name
typeclass)]
) [Name]
i
#if MIN_VERSION_template_haskell(2,15,0)
let kd :: Dec
kd = if Bool
useNewtype
then [Type]
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
k) Type
recordType) Maybe Type
forall a. Maybe a
Nothing Con
dec [DerivClause]
deriveClauses
else [Type]
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
k) Type
recordType) Maybe Type
forall a. Maybe a
Nothing [Con
dec] [DerivClause]
deriveClauses
#else
let kd = if useNewtype
then NewtypeInstD [] k [recordType] Nothing dec deriveClauses
else DataInstD [] k [recordType] Nothing [dec] deriveClauses
#endif
(Dec, [Dec]) -> Q (Dec, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
kd, [Dec]
instDecs)
where
keyConE :: Exp
keyConE = UnboundEntityDef -> Exp
keyConExp UnboundEntityDef
entDef
unKeyE :: Exp
unKeyE = UnboundEntityDef -> Exp
unKeyExp UnboundEntityDef
entDef
dec :: Con
dec = Name -> [VarBangType] -> Con
RecC (UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef) (MkPersistSettings -> UnboundEntityDef -> [VarBangType]
keyFields MkPersistSettings
mps UnboundEntityDef
entDef)
k :: Name
k = ''Key
recordType :: Type
recordType =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef) Type
backendT
pfInstD :: Q [Dec]
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 :: Q [Dec]
backendKeyGenericI =
[d| instance PersistStore $(pure backendT) =>
ToBackendKey $(pure backendT) $(pure recordType) where
toBackendKey = $(return unKeyE)
fromBackendKey = $(return keyConE)
|]
backendKeyI :: Q [Dec]
backendKeyI = let bdt :: Type
bdt = MkPersistSettings -> Type
backendDataType MkPersistSettings
mps in
[d| instance ToBackendKey $(pure bdt) $(pure recordType) where
toBackendKey = $(return unKeyE)
fromBackendKey = $(return keyConE)
|]
genericNewtypeInstances :: Q [Dec]
genericNewtypeInstances = do
Q ()
requirePersistentExtensions
[Dec]
alwaysInstances <-
[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))
|]
[Dec] -> [Dec] -> [Dec]
forall m. Monoid m => m -> m -> m
mappend [Dec]
alwaysInstances ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
if Bool
customKeyType
then [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else Q [Dec]
backendKeyGenericI
useNewtype :: Bool
useNewtype = MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype MkPersistSettings
mps UnboundEntityDef
entDef
customKeyType :: Bool
customKeyType =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
[ Bool -> Bool
not (UnboundEntityDef -> Bool
defaultIdType UnboundEntityDef
entDef)
, Bool -> Bool
not Bool
useNewtype
, Maybe CompositeDef -> Bool
forall a. Maybe a -> Bool
isJust (EntityDef -> Maybe CompositeDef
entityPrimary (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef))
, Bool -> Bool
not Bool
isBackendKey
]
isBackendKey :: Bool
isBackendKey =
case MkPersistSettings -> Type
getImplicitIdType MkPersistSettings
mps of
ConT Name
bk `AppT` Type
_
| Name
bk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''BackendKey ->
Bool
True
Type
_ ->
Bool
False
supplement :: [Name] -> [Name]
supplement :: [Name] -> [Name]
supplement [Name]
names = [Name]
names [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
names) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> [Name]
mpsDeriveInstances MkPersistSettings
mps)
pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype MkPersistSettings
mps UnboundEntityDef
entDef = [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (MkPersistSettings -> UnboundEntityDef -> [VarBangType]
keyFields MkPersistSettings
mps UnboundEntityDef
entDef) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
defaultIdType :: UnboundEntityDef -> Bool
defaultIdType :: UnboundEntityDef -> Bool
defaultIdType UnboundEntityDef
entDef =
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
DefaultKey FieldNameDB
_ ->
Bool
True
PrimarySpec
_ ->
Bool
False
keyFields :: MkPersistSettings -> UnboundEntityDef -> [(Name, Strict, Type)]
keyFields :: MkPersistSettings -> UnboundEntityDef -> [VarBangType]
keyFields MkPersistSettings
mps UnboundEntityDef
entDef =
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
NaturalKey UnboundCompositeDef
ucd ->
(FieldNameHS -> VarBangType) -> [FieldNameHS] -> [VarBangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldNameHS -> VarBangType
naturalKeyVar (UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd)
DefaultKey FieldNameDB
_ ->
VarBangType -> [VarBangType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarBangType -> [VarBangType])
-> (Type -> VarBangType) -> Type -> [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar (Type -> [VarBangType]) -> Type -> [VarBangType]
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> Type
getImplicitIdType MkPersistSettings
mps
SurrogateKey UnboundIdDef
k ->
VarBangType -> [VarBangType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarBangType -> [VarBangType])
-> (Type -> VarBangType) -> Type -> [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar (Type -> [VarBangType]) -> Type -> [VarBangType]
forall a b. (a -> b) -> a -> b
$ case UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
k of
Maybe FieldType
Nothing ->
MkPersistSettings -> Type
getImplicitIdType MkPersistSettings
mps
Just FieldType
ty ->
FieldType -> Type
ftToType FieldType
ty
where
unboundFieldDefs :: [UnboundFieldDef]
unboundFieldDefs =
UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
naturalKeyVar :: FieldNameHS -> VarBangType
naturalKeyVar FieldNameHS
fieldName =
case FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
findField FieldNameHS
fieldName [UnboundFieldDef]
unboundFieldDefs of
Maybe UnboundFieldDef
Nothing ->
String -> VarBangType
forall a. HasCallStack => String -> a
error String
"column not defined on entity"
Just UnboundFieldDef
unboundFieldDef ->
( MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
keyFieldName MkPersistSettings
mps UnboundEntityDef
entDef (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
unboundFieldDef)
, Bang
notStrict
, FieldType -> Type
ftToType (FieldType -> Type) -> FieldType -> Type
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
unboundFieldDef
)
idKeyVar :: Type -> VarBangType
idKeyVar Type
ft =
( UnboundEntityDef -> Name
unKeyName UnboundEntityDef
entDef
, Bang
notStrict
, Type
ft
)
findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
findField FieldNameHS
fieldName =
(UnboundFieldDef -> Bool)
-> [UnboundFieldDef] -> Maybe UnboundFieldDef
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((FieldNameHS
fieldName FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
==) (FieldNameHS -> Bool)
-> (UnboundFieldDef -> FieldNameHS) -> UnboundFieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS)
mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyToValues MkPersistSettings
mps UnboundEntityDef
entDef = do
Name
recordName <- String -> Q Name
newName String
"record"
Name -> [Clause] -> Dec
FunD 'keyToValues ([Clause] -> Dec) -> (Clause -> [Clause]) -> Clause -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clause -> [Clause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Dec) -> Q Clause -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
NaturalKey UnboundCompositeDef
ucd -> do
[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
recordName] (Exp -> Clause) -> Q Exp -> Q Clause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Name -> UnboundCompositeDef -> Q Exp
toValuesPrimary Name
recordName UnboundCompositeDef
ucd
PrimarySpec
_ -> do
[Pat] -> Exp -> Clause
normalClause [] (Exp -> Clause) -> Q Exp -> Q Clause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|]
where
toValuesPrimary :: Name -> UnboundCompositeDef -> Q Exp
toValuesPrimary Name
recName UnboundCompositeDef
ucd =
[Exp] -> Exp
ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldNameHS -> Q Exp) -> [FieldNameHS] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> FieldNameHS -> Q Exp
f Name
recName) (UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd)
f :: Name -> FieldNameHS -> Q Exp
f Name
recName FieldNameHS
fieldNameHS =
[|
toPersistValue ($(varE $ keyFieldName mps entDef fieldNameHS) $(varE recName))
|]
normalClause :: [Pat] -> Exp -> Clause
normalClause :: [Pat] -> Exp -> Clause
normalClause [Pat]
p Exp
e = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
p (Exp -> Body
NormalB Exp
e) []
mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues MkPersistSettings
_mps UnboundEntityDef
entDef =
Name -> [Clause] -> Dec
FunD 'keyFromValues ([Clause] -> Dec) -> Q [Clause] -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
NaturalKey UnboundCompositeDef
ucd ->
UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues UnboundEntityDef
entDef Text
"keyFromValues" Exp
keyConE (UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd)
PrimarySpec
_ -> do
Exp
e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
[Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Exp -> Clause
normalClause [] Exp
e]
where
keyConE :: Exp
keyConE = UnboundEntityDef -> Exp
keyConExp UnboundEntityDef
entDef
headNote :: [PersistValue] -> PersistValue
headNote :: [PersistValue] -> PersistValue
headNote = \case
[PersistValue
x] -> PersistValue
x
[PersistValue]
xs -> String -> PersistValue
forall a. HasCallStack => String -> a
error (String -> PersistValue) -> String -> PersistValue
forall a b. (a -> b) -> a -> b
$ String
"mkKeyFromValues: expected a list of one element, got: " String -> ShowS
forall m. Monoid m => m -> m -> m
`mappend` [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
xs
fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues UnboundEntityDef
entDef Text
funName Exp
constructExpr [FieldNameHS]
fields = do
Name
x <- String -> Q Name
newName String
"x"
let
funMsg :: Text
funMsg =
[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ UnboundEntityDef -> Text
entityText UnboundEntityDef
entDef
, Text
": "
, Text
funName
, Text
" failed on: "
]
Exp
patternMatchFailure <-
[|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
Clause
suc <- Q Clause
patternSuccess
[Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Clause
suc, [Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
x] Exp
patternMatchFailure ]
where
tableName :: Text
tableName =
EntityNameDB -> Text
unEntityNameDB (EntityDef -> EntityNameDB
entityDB (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef))
patternSuccess :: Q Clause
patternSuccess =
case [FieldNameHS]
fields of
[] -> do
Exp
rightE <- [|Right|]
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [[Pat] -> Pat
ListP []] (Exp
rightE Exp -> Exp -> Exp
`AppE` Exp
constructExpr)
[FieldNameHS]
_ -> do
Name
x1 <- String -> Q Name
newName String
"x1"
[Name]
restNames <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
i -> String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"x" String -> ShowS
forall m. Monoid m => m -> m -> m
`mappend` Int -> String
forall a. Show a => a -> String
show Int
i) [Int
2..[FieldNameHS] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldNameHS]
fields]
(Exp
fpv1:[Exp]
mkPersistValues) <- (FieldNameHS -> Q Exp) -> [FieldNameHS] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldNameHS -> Q Exp
mkPersistValue [FieldNameHS]
fields
Exp
app1E <- [|(<$>)|]
let conApp :: Exp
conApp = Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
app1E Exp
fpv1 Exp
constructExpr Name
x1
Exp
applyE <- [|(<*>)|]
let applyFromPersistValue :: Exp -> Exp -> Name -> Exp
applyFromPersistValue = Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
applyE
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
[[Pat] -> Pat
ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP (Name
x1Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
restNames)]
((Exp -> FieldExp -> Exp) -> Exp -> [FieldExp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
exp (Name
name, Exp
fpv) -> Exp -> Exp -> Name -> Exp
applyFromPersistValue Exp
fpv Exp
exp Name
name) Exp
conApp ([Name] -> [Exp] -> [FieldExp]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
restNames [Exp]
mkPersistValues))
infixFromPersistValue :: Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
applyE Exp
fpv Exp
exp Name
name =
Exp -> Exp -> Exp -> Exp
UInfixE Exp
exp Exp
applyE (Exp
fpv Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
name)
mkPersistValue :: FieldNameHS -> Q Exp
mkPersistValue FieldNameHS
field =
let fieldName :: Text
fieldName = FieldNameHS -> Text
unFieldNameHS FieldNameHS
field
in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|]
fieldError :: Text -> Text -> Text -> Text
fieldError :: Text -> Text -> Text -> Text
fieldError Text
tableName Text
fieldName Text
err = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ Text
"Couldn't parse field `"
, Text
fieldName
, Text
"` from table `"
, Text
tableName
, Text
"`. "
, Text
err
]
mkEntity :: M.Map EntityNameHS a -> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkEntity :: Map EntityNameHS a
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkEntity Map EntityNameHS a
embedEntityMap EntityMap
entityMap MkPersistSettings
mps UnboundEntityDef
preDef = do
Exp
entityDefExp <- MkPersistSettings
-> Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp
forall a.
MkPersistSettings
-> Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp
liftAndFixKeys MkPersistSettings
mps Map EntityNameHS a
embedEntityMap EntityMap
entityMap UnboundEntityDef
preDef
let
entDef :: UnboundEntityDef
entDef =
UnboundEntityDef -> UnboundEntityDef
fixEntityDef UnboundEntityDef
preDef
EntityFieldsTH
fields <- MkPersistSettings
-> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
mkFields MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
let name :: Name
name = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef
let clazz :: Type
clazz = Name -> Type
ConT ''PersistEntity Type -> Type -> Type
`AppT` Type
genDataType
Dec
tpf <- MkPersistSettings -> UnboundEntityDef -> Q Dec
mkToPersistFields MkPersistSettings
mps UnboundEntityDef
entDef
[Clause]
fpv <- MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues MkPersistSettings
mps UnboundEntityDef
entDef
Dec
utv <- [UniqueDef] -> Q Dec
mkUniqueToValues ([UniqueDef] -> Q Dec) -> [UniqueDef] -> Q Dec
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques (EntityDef -> [UniqueDef]) -> EntityDef -> [UniqueDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef
Dec
puk <- UnboundEntityDef -> Q Dec
mkUniqueKeys UnboundEntityDef
entDef
[[Dec]]
fkc <- (UnboundForeignDef -> Q [Dec]) -> [UnboundForeignDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings
-> UnboundEntityDef -> UnboundForeignDef -> Q [Dec]
mkForeignKeysComposite MkPersistSettings
mps UnboundEntityDef
entDef) ([UnboundForeignDef] -> Q [[Dec]])
-> [UnboundForeignDef] -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundForeignDef]
unboundForeignDefs UnboundEntityDef
entDef
Dec
toFieldNames <- [UniqueDef] -> Q Dec
mkToFieldNames ([UniqueDef] -> Q Dec) -> [UniqueDef] -> Q Dec
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques (EntityDef -> [UniqueDef]) -> EntityDef -> [UniqueDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef
(Dec
keyTypeDec, [Dec]
keyInstanceDecs) <- MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec MkPersistSettings
mps UnboundEntityDef
entDef
Dec
keyToValues' <- MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyToValues MkPersistSettings
mps UnboundEntityDef
entDef
Dec
keyFromValues' <- MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues MkPersistSettings
mps UnboundEntityDef
entDef
let addSyn :: [Dec] -> [Dec]
addSyn
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps = (:) (Dec -> [Dec] -> [Dec]) -> Dec -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$
Name -> [TyVarBndr] -> Type -> Dec
TySynD Name
name [] (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
entName (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> Type
mpsBackend MkPersistSettings
mps
| Bool
otherwise = [Dec] -> [Dec]
forall a. a -> a
id
[Clause]
lensClauses <- MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
mkLensClauses MkPersistSettings
mps UnboundEntityDef
entDef Type
genDataType
[Dec]
lenses <- MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkLenses MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
let instanceConstraint :: [Type]
instanceConstraint = if Bool -> Bool
not (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) then [] else
[Name -> [Type] -> Type
mkClassP ''PersistStore [Type
backendT]]
[Dec
keyFromRecordM'] <-
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
NaturalKey UnboundCompositeDef
ucd -> do
Name
recordName <- String -> Q Name
newName String
"record"
let
keyCon :: Name
keyCon =
UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef
keyFields' :: [Name]
keyFields' =
MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef (FieldNameHS -> Name) -> [FieldNameHS] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd
constr :: Exp
constr =
(Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
Exp -> Exp -> Exp
AppE
(Name -> Exp
ConE Name
keyCon)
([Exp] -> [Exp]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([Exp] -> [Exp]) -> [Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\Name
n ->
Name -> Exp
VarE Name
n Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
recordName
)
[Name]
keyFields'
)
keyFromRec :: Q Pat
keyFromRec = Name -> Q Pat
varP 'keyFromRecordM
[d|
$(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr))
|]
PrimarySpec
_ ->
[d|$(varP 'keyFromRecordM) = Nothing|]
Dec
dtd <- MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec
dataTypeDec MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
let
allEntDefs :: [Con]
allEntDefs =
EntityFieldTH -> Con
entityFieldTHCon (EntityFieldTH -> Con) -> [EntityFieldTH] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityFieldsTH -> [EntityFieldTH]
efthAllFields EntityFieldsTH
fields
allEntDefClauses :: [Clause]
allEntDefClauses =
EntityFieldTH -> Clause
entityFieldTHClause (EntityFieldTH -> Clause) -> [EntityFieldTH] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityFieldsTH -> [EntityFieldTH]
efthAllFields EntityFieldsTH
fields
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec] -> [Dec]
addSyn ([Dec] -> [Dec]) -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$
Dec
dtd Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat [[Dec]]
fkc [Dec] -> [Dec] -> [Dec]
forall m. Monoid m => m -> m -> m
`mappend`
( [ Name -> [TyVarBndr] -> Type -> Dec
TySynD (UnboundEntityDef -> Name
keyIdName UnboundEntityDef
entDef) [] (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$
Name -> Type
ConT ''Key Type -> Type -> Type
`AppT` Name -> Type
ConT Name
name
, [Type] -> Type -> [Dec] -> Dec
instanceD [Type]
instanceConstraint Type
clazz
[ MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
uniqueTypeDec MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
, Dec
keyTypeDec
, Dec
keyToValues'
, Dec
keyFromValues'
, Dec
keyFromRecordM'
, Name -> [Clause] -> Dec
FunD 'entityDef [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
entityDefExp]
, Dec
tpf
, Name -> [Clause] -> Dec
FunD 'fromPersistValues [Clause]
fpv
, Dec
toFieldNames
, Dec
utv
, Dec
puk
#if MIN_VERSION_template_haskell(2,15,0)
, [Type]
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD
[]
Maybe [TyVarBndr]
forall a. Maybe a
Nothing
(Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''EntityField) Type
genDataType) (Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ"))
Maybe Type
forall a. Maybe a
Nothing
[Con]
allEntDefs
[]
#else
, DataInstD
[]
''EntityField
[ genDataType
, VarT $ mkName "typ"
]
Nothing
allEntDefs
[]
#endif
, Name -> [Clause] -> Dec
FunD 'persistFieldDef [Clause]
allEntDefClauses
#if MIN_VERSION_template_haskell(2,15,0)
, TySynEqn -> Dec
TySynInstD
(Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn
Maybe [TyVarBndr]
forall a. Maybe a
Nothing
(Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistEntityBackend) Type
genDataType)
(MkPersistSettings -> Type
backendDataType MkPersistSettings
mps))
#else
, TySynInstD
''PersistEntityBackend
(TySynEqn
[genDataType]
(backendDataType mps))
#endif
, Name -> [Clause] -> Dec
FunD 'persistIdField [[Pat] -> Exp -> Clause
normalClause [] (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> Name
keyIdName UnboundEntityDef
entDef)]
, Name -> [Clause] -> Dec
FunD 'fieldLens [Clause]
lensClauses
]
] [Dec] -> [Dec] -> [Dec]
forall m. Monoid m => m -> m -> m
`mappend` [Dec]
lenses) [Dec] -> [Dec] -> [Dec]
forall m. Monoid m => m -> m -> m
`mappend` [Dec]
keyInstanceDecs
where
genDataType :: Type
genDataType =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
entName Type
backendT
entName :: EntityNameHS
entName =
UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
preDef
data EntityFieldsTH = EntityFieldsTH
{ EntityFieldsTH -> EntityFieldTH
entityFieldsTHPrimary :: EntityFieldTH
, EntityFieldsTH -> [EntityFieldTH]
entityFieldsTHFields :: [EntityFieldTH]
}
efthAllFields :: EntityFieldsTH -> [EntityFieldTH]
efthAllFields :: EntityFieldsTH -> [EntityFieldTH]
efthAllFields EntityFieldsTH{[EntityFieldTH]
EntityFieldTH
entityFieldsTHFields :: [EntityFieldTH]
entityFieldsTHPrimary :: EntityFieldTH
entityFieldsTHFields :: EntityFieldsTH -> [EntityFieldTH]
entityFieldsTHPrimary :: EntityFieldsTH -> EntityFieldTH
..} =
EntityFieldTH -> EntityFieldTH
stripIdFieldDef EntityFieldTH
entityFieldsTHPrimary EntityFieldTH -> [EntityFieldTH] -> [EntityFieldTH]
forall a. a -> [a] -> [a]
: [EntityFieldTH]
entityFieldsTHFields
stripIdFieldDef :: EntityFieldTH -> EntityFieldTH
stripIdFieldDef :: EntityFieldTH -> EntityFieldTH
stripIdFieldDef EntityFieldTH
efth = EntityFieldTH
efth
{ entityFieldTHClause :: Clause
entityFieldTHClause =
Clause -> Clause
go (EntityFieldTH -> Clause
entityFieldTHClause EntityFieldTH
efth)
}
where
go :: Clause -> Clause
go (Clause [Pat]
ps Body
bdy [Dec]
ds) =
[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
ps Body
bdy' [Dec]
ds
where
bdy' :: Body
bdy' =
case Body
bdy of
NormalB Exp
e ->
Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'stripIdFieldImpl) Exp
e
Body
_ ->
Body
bdy
stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef
stripIdFieldImpl :: EntityIdDef -> FieldDef
stripIdFieldImpl EntityIdDef
eid =
case EntityIdDef
eid of
EntityIdField FieldDef
fd -> FieldDef
fd
EntityIdNaturalKey CompositeDef
cd ->
case CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
cd of
(FieldDef
x :| [FieldDef]
xs) ->
case [FieldDef]
xs of
[] ->
FieldDef
x
[FieldDef]
_ ->
FieldDef
dummyFieldDef
where
dummyFieldDef :: FieldDef
dummyFieldDef =
FieldDef :: FieldNameHS
-> FieldNameDB
-> FieldType
-> SqlType
-> [FieldAttr]
-> Bool
-> ReferenceDef
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> Bool
-> FieldDef
FieldDef
{ fieldHaskell :: FieldNameHS
fieldHaskell =
Text -> FieldNameHS
FieldNameHS Text
"Id"
, fieldDB :: FieldNameDB
fieldDB =
Text -> FieldNameDB
FieldNameDB Text
"__composite_key_no_id__"
, fieldType :: FieldType
fieldType =
Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
"__Composite_Key__"
, fieldSqlType :: SqlType
fieldSqlType =
Text -> SqlType
SqlOther Text
"Composite Key"
, fieldAttrs :: [FieldAttr]
fieldAttrs =
[]
, fieldStrict :: Bool
fieldStrict =
Bool
False
, fieldReference :: ReferenceDef
fieldReference =
ReferenceDef
NoReference
, fieldCascade :: FieldCascade
fieldCascade =
FieldCascade
noCascade
, fieldComments :: Maybe Text
fieldComments =
Maybe Text
forall a. Maybe a
Nothing
, fieldGenerated :: Maybe Text
fieldGenerated =
Maybe Text
forall a. Maybe a
Nothing
, fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn =
Bool
False
}
mkFields :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
mkFields :: MkPersistSettings
-> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
mkFields MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef =
EntityFieldTH -> [EntityFieldTH] -> EntityFieldsTH
EntityFieldsTH
(EntityFieldTH -> [EntityFieldTH] -> EntityFieldsTH)
-> Q EntityFieldTH -> Q ([EntityFieldTH] -> EntityFieldsTH)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
mkIdField MkPersistSettings
mps UnboundEntityDef
entDef
Q ([EntityFieldTH] -> EntityFieldsTH)
-> Q [EntityFieldTH] -> Q EntityFieldsTH
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (UnboundFieldDef -> Q EntityFieldTH)
-> [UnboundFieldDef] -> Q [EntityFieldTH]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings
-> EntityMap
-> UnboundEntityDef
-> UnboundFieldDef
-> Q EntityFieldTH
mkField MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef) (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef)
mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances MkPersistSettings
mps UnboundEntityDef
entDef = do
Q ()
requirePersistentExtensions
case EntityDef -> [UniqueDef]
entityUniques (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef) of
[] -> [Dec] -> [Dec] -> [Dec]
forall m. Monoid m => m -> m -> m
mappend ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
typeErrorSingle Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
typeErrorAtLeastOne
[UniqueDef
_] -> [Dec] -> [Dec] -> [Dec]
forall m. Monoid m => m -> m -> m
mappend ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
singleUniqueKey Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
atLeastOneKey
(UniqueDef
_:[UniqueDef]
_) -> [Dec] -> [Dec] -> [Dec]
forall m. Monoid m => m -> m -> m
mappend ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
typeErrorMultiple Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
atLeastOneKey
where
requireUniquesPName :: Name
requireUniquesPName = 'requireUniquesP
onlyUniquePName :: Name
onlyUniquePName = 'onlyUniqueP
typeErrorSingle :: Q [Dec]
typeErrorSingle = Q [Type] -> Q [Dec]
mkOnlyUniqueError Q [Type]
typeErrorNoneCtx
typeErrorMultiple :: Q [Dec]
typeErrorMultiple = Q [Type] -> Q [Dec]
mkOnlyUniqueError Q [Type]
typeErrorMultipleCtx
withPersistStoreWriteCxt :: Q [Type]
withPersistStoreWriteCxt =
if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
then do
Type
write <- [t|PersistStoreWrite $(pure backendT) |]
[Type] -> Q [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type
write]
else do
[Type] -> Q [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
typeErrorNoneCtx :: Q [Type]
typeErrorNoneCtx = do
Type
tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|]
(Type
tyErr Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:) ([Type] -> [Type]) -> Q [Type] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
withPersistStoreWriteCxt
typeErrorMultipleCtx :: Q [Type]
typeErrorMultipleCtx = do
Type
tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|]
(Type
tyErr Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:) ([Type] -> [Type]) -> Q [Type] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
withPersistStoreWriteCxt
mkOnlyUniqueError :: Q Cxt -> Q [Dec]
mkOnlyUniqueError :: Q [Type] -> Q [Dec]
mkOnlyUniqueError Q [Type]
mkCtx = do
[Type]
ctx <- Q [Type]
mkCtx
let impl :: [Dec]
impl = Name -> [Dec]
mkImpossible Name
onlyUniquePName
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
ctx Type
onlyOneUniqueKeyClass [Dec]
impl]
mkImpossible :: Name -> [Dec]
mkImpossible Name
name =
[ Name -> [Clause] -> Dec
FunD Name
name
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[ Pat
WildP ]
(Exp -> Body
NormalB
(Name -> Exp
VarE 'error Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
"impossible"))
)
[]
]
]
typeErrorAtLeastOne :: Q [Dec]
typeErrorAtLeastOne :: Q [Dec]
typeErrorAtLeastOne = do
let impl :: [Dec]
impl = Name -> [Dec]
mkImpossible Name
requireUniquesPName
[Type]
cxt <- Q [Type]
typeErrorMultipleCtx
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt Type
atLeastOneUniqueKeyClass [Dec]
impl]
singleUniqueKey :: Q [Dec]
singleUniqueKey :: Q [Dec]
singleUniqueKey = do
Exp
expr <- [e| head . persistUniqueKeys|]
let impl :: [Dec]
impl = [Name -> [Clause] -> Dec
FunD Name
onlyUniquePName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
[Type]
cxt <- Q [Type]
withPersistStoreWriteCxt
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt Type
onlyOneUniqueKeyClass [Dec]
impl]
atLeastOneUniqueKeyClass :: Type
atLeastOneUniqueKeyClass = Name -> Type
ConT ''AtLeastOneUniqueKey Type -> Type -> Type
`AppT` Type
genDataType
onlyOneUniqueKeyClass :: Type
onlyOneUniqueKeyClass = Name -> Type
ConT ''OnlyOneUniqueKey Type -> Type -> Type
`AppT` Type
genDataType
atLeastOneKey :: Q [Dec]
atLeastOneKey :: Q [Dec]
atLeastOneKey = do
Exp
expr <- [e| NEL.fromList . persistUniqueKeys|]
let impl :: [Dec]
impl = [Name -> [Clause] -> Dec
FunD Name
requireUniquesPName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
[Type]
cxt <- Q [Type]
withPersistStoreWriteCxt
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt Type
atLeastOneUniqueKeyClass [Dec]
impl]
genDataType :: Type
genDataType =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef) Type
backendT
entityText :: UnboundEntityDef -> Text
entityText :: UnboundEntityDef -> Text
entityText = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS
mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkLenses MkPersistSettings
mps EntityMap
_ UnboundEntityDef
_ | Bool -> Bool
not (MkPersistSettings -> Bool
mpsGenerateLenses MkPersistSettings
mps) = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkLenses MkPersistSettings
_ EntityMap
_ UnboundEntityDef
ent | EntityDef -> Bool
entitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent) = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkLenses MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
ent = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [(UnboundFieldDef, Name)]
-> ((UnboundFieldDef, Name) -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ent [UnboundFieldDef] -> [Name] -> [(UnboundFieldDef, Name)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
fieldNames) (((UnboundFieldDef, Name) -> Q [Dec]) -> Q [[Dec]])
-> ((UnboundFieldDef, Name) -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \(UnboundFieldDef
field, Name
fieldName) -> do
let lensName :: Name
lensName = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName MkPersistSettings
mps UnboundEntityDef
ent UnboundFieldDef
field
Name
needleN <- String -> Q Name
newName String
"needle"
Name
setterN <- String -> Q Name
newName String
"setter"
Name
fN <- String -> Q Name
newName String
"f"
Name
aN <- String -> Q Name
newName String
"a"
Name
yN <- String -> Q Name
newName String
"y"
let needle :: Exp
needle = Name -> Exp
VarE Name
needleN
setter :: Exp
setter = Name -> Exp
VarE Name
setterN
f :: Exp
f = Name -> Exp
VarE Name
fN
a :: Exp
a = Name -> Exp
VarE Name
aN
y :: Exp
y = Name -> Exp
VarE Name
yN
fT :: Name
fT = String -> Name
mkName String
"f"
backend1 :: Name
backend1 = Name
backendName
backend2 :: Name
backend2 = Name
backendName
aT :: Type
aT =
MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
field (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
backend1) Maybe IsNullable
forall a. Maybe a
Nothing
bT :: Type
bT =
MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
field (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
backend2) Maybe IsNullable
forall a. Maybe a
Nothing
mkST :: Name -> Type
mkST Name
backend =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ent) (Name -> Type
VarT Name
backend)
sT :: Type
sT = Name -> Type
mkST Name
backend1
tT :: Type
tT = Name -> Type
mkST Name
backend2
Type
t1 arrow :: Type -> Type -> Type
`arrow` Type
t2 = Type
ArrowT Type -> Type -> Type
`AppT` Type
t1 Type -> Type -> Type
`AppT` Type
t2
vars :: [TyVarBndr]
vars = Name -> TyVarBndr
mkForallTV Name
fT
TyVarBndr -> [TyVarBndr] -> [TyVarBndr]
forall a. a -> [a] -> [a]
: (if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps then [Name -> TyVarBndr
mkForallTV Name
backend1] else [])
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Name -> Type -> Dec
SigD Name
lensName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
vars [Name -> [Type] -> Type
mkClassP ''Functor [Name -> Type
VarT Name
fT]] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
(Type
aT Type -> Type -> Type
`arrow` (Name -> Type
VarT Name
fT Type -> Type -> Type
`AppT` Type
bT)) Type -> Type -> Type
`arrow`
(Type
sT Type -> Type -> Type
`arrow` (Name -> Type
VarT Name
fT Type -> Type -> Type
`AppT` Type
tT))
, Name -> [Clause] -> Dec
FunD Name
lensName ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> Pat
VarP Name
fN, Name -> Pat
VarP Name
aN]
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp
fmapE
Exp -> Exp -> Exp
`AppE` Exp
setter
Exp -> Exp -> Exp
`AppE` (Exp
f Exp -> Exp -> Exp
`AppE` Exp
needle))
[ Name -> [Clause] -> Dec
FunD Name
needleN [[Pat] -> Exp -> Clause
normalClause [] (Name -> Name -> Exp
fieldSel (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ent) Name
fieldName Exp -> Exp -> Exp
`AppE` Exp
a)]
, Name -> [Clause] -> Dec
FunD Name
setterN ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
[Name -> Pat
VarP Name
yN]
(Name -> [Name] -> Exp -> Name -> Exp -> Exp
fieldUpd (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ent) [Name]
fieldNames Exp
a Name
fieldName Exp
y)
]
]
where
fieldNames :: [Name]
fieldNames = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
ent (UnboundFieldDef -> Name) -> [UnboundFieldDef] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ent
#if MIN_VERSION_template_haskell(2,17,0)
mkPlainTV
:: Name
-> TyVarBndr ()
mkPlainTV n = PlainTV n ()
mkDoE :: [Stmt] -> Exp
mkDoE stmts = DoE Nothing stmts
mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV n = PlainTV n SpecifiedSpec
#else
mkDoE :: [Stmt] -> Exp
mkDoE :: [Stmt] -> Exp
mkDoE = [Stmt] -> Exp
DoE
mkPlainTV
:: Name
-> TyVarBndr
mkPlainTV :: Name -> TyVarBndr
mkPlainTV = Name -> TyVarBndr
PlainTV
mkForallTV
:: Name
-> TyVarBndr
mkForallTV :: Name -> TyVarBndr
mkForallTV = Name -> TyVarBndr
mkPlainTV
#endif
mkForeignKeysComposite
:: MkPersistSettings
-> UnboundEntityDef
-> UnboundForeignDef
-> Q [Dec]
mkForeignKeysComposite :: MkPersistSettings
-> UnboundEntityDef -> UnboundForeignDef -> Q [Dec]
mkForeignKeysComposite MkPersistSettings
mps UnboundEntityDef
entDef UnboundForeignDef
foreignDef
| ForeignDef -> Bool
foreignToPrimary (UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef) = do
let
fieldName :: FieldNameHS -> Name
fieldName =
MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef
fname :: Name
fname =
FieldNameHS -> Name
fieldName (FieldNameHS -> Name) -> FieldNameHS -> Name
forall a b. (a -> b) -> a -> b
$ ConstraintNameHS -> FieldNameHS
constraintToField (ConstraintNameHS -> FieldNameHS)
-> ConstraintNameHS -> FieldNameHS
forall a b. (a -> b) -> a -> b
$ ForeignDef -> ConstraintNameHS
foreignConstraintNameHaskell (ForeignDef -> ConstraintNameHS) -> ForeignDef -> ConstraintNameHS
forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef
reftableString :: String
reftableString =
Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ ForeignDef -> EntityNameHS
foreignRefTableHaskell (ForeignDef -> EntityNameHS) -> ForeignDef -> EntityNameHS
forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef
reftableKeyName :: Name
reftableKeyName =
String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
reftableString String -> ShowS
forall m. Monoid m => m -> m -> m
`mappend` String
"Key"
tablename :: Name
tablename =
UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef
fieldStore :: FieldStore
fieldStore =
UnboundEntityDef -> FieldStore
mkFieldStore UnboundEntityDef
entDef
Name
recordName <- String -> Q Name
newName String
"record_mkForeignKeysComposite"
let
mkFldE :: FieldNameHS -> Exp
mkFldE FieldNameHS
foreignName =
Name -> Exp
VarE 'coerce Exp -> Exp -> Exp
`AppE`
(Name -> Exp
VarE (FieldNameHS -> Name
fieldName FieldNameHS
foreignName) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
recordName)
mkFldR :: ForeignFieldReference -> Exp
mkFldR ForeignFieldReference
ffr =
let
e :: Exp
e =
FieldNameHS -> Exp
mkFldE (ForeignFieldReference -> FieldNameHS
ffrSourceField ForeignFieldReference
ffr)
in
case ForeignFieldReference -> FieldNameHS
ffrTargetField ForeignFieldReference
ffr of
FieldNameHS Text
"Id" ->
Name -> Exp
VarE 'toBackendKey Exp -> Exp -> Exp
`AppE`
Exp
e
FieldNameHS
_ ->
Exp
e
foreignFieldNames :: UnboundForeignFieldList -> NonEmpty FieldNameHS
foreignFieldNames UnboundForeignFieldList
foreignFieldList =
case UnboundForeignFieldList
foreignFieldList of
FieldListImpliedId NonEmpty FieldNameHS
names ->
NonEmpty FieldNameHS
names
FieldListHasReferences NonEmpty ForeignFieldReference
refs ->
(ForeignFieldReference -> FieldNameHS)
-> NonEmpty ForeignFieldReference -> NonEmpty FieldNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> FieldNameHS
ffrSourceField NonEmpty ForeignFieldReference
refs
fldsE :: NonEmpty Exp
fldsE =
UnboundForeignFieldList -> NonEmpty Exp
getForeignNames (UnboundForeignFieldList -> NonEmpty Exp)
-> UnboundForeignFieldList -> NonEmpty Exp
forall a b. (a -> b) -> a -> b
$ (UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields UnboundForeignDef
foreignDef)
getForeignNames :: UnboundForeignFieldList -> NonEmpty Exp
getForeignNames = \case
FieldListImpliedId NonEmpty FieldNameHS
xs ->
(FieldNameHS -> Exp) -> NonEmpty FieldNameHS -> NonEmpty Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldNameHS -> Exp
mkFldE NonEmpty FieldNameHS
xs
FieldListHasReferences NonEmpty ForeignFieldReference
xs ->
(ForeignFieldReference -> Exp)
-> NonEmpty ForeignFieldReference -> NonEmpty Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> Exp
mkFldR NonEmpty ForeignFieldReference
xs
nullErr :: a -> a
nullErr a
n =
String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Could not find field definition for: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n
fNullable :: Bool
fNullable =
NonEmpty UnboundFieldDef -> Bool
setNull
(NonEmpty UnboundFieldDef -> Bool)
-> NonEmpty UnboundFieldDef -> Bool
forall a b. (a -> b) -> a -> b
$ (FieldNameHS -> UnboundFieldDef)
-> NonEmpty FieldNameHS -> NonEmpty UnboundFieldDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNameHS
n -> UnboundFieldDef -> Maybe UnboundFieldDef -> UnboundFieldDef
forall a. a -> Maybe a -> a
fromMaybe (FieldNameHS -> UnboundFieldDef
forall a a. Show a => a -> a
nullErr FieldNameHS
n) (Maybe UnboundFieldDef -> UnboundFieldDef)
-> Maybe UnboundFieldDef -> UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef FieldNameHS
n FieldStore
fieldStore)
(NonEmpty FieldNameHS -> NonEmpty UnboundFieldDef)
-> NonEmpty FieldNameHS -> NonEmpty UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ UnboundForeignFieldList -> NonEmpty FieldNameHS
foreignFieldNames
(UnboundForeignFieldList -> NonEmpty FieldNameHS)
-> UnboundForeignFieldList -> NonEmpty FieldNameHS
forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields UnboundForeignDef
foreignDef
mkKeyE :: Exp
mkKeyE =
(Exp -> Exp -> Exp) -> Exp -> NonEmpty Exp -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Bool -> Exp -> Exp
maybeExp Bool
fNullable (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
reftableKeyName) NonEmpty Exp
fldsE
fn :: Dec
fn =
Name -> [Clause] -> Dec
FunD Name
fname [[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
recordName] Exp
mkKeyE]
keyTargetTable :: Type
keyTargetTable =
Bool -> Type -> Type
maybeTyp Bool
fNullable (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Key Type -> Type -> Type
`AppT` Name -> Type
ConT (String -> Name
mkName String
reftableString)
Type
sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |]
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
SigD Name
fname Type
sigTy
, Dec
fn
]
| Bool
otherwise =
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
where
constraintToField :: ConstraintNameHS -> FieldNameHS
constraintToField = Text -> FieldNameHS
FieldNameHS (Text -> FieldNameHS)
-> (ConstraintNameHS -> Text) -> ConstraintNameHS -> FieldNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintNameHS -> Text
unConstraintNameHS
maybeExp :: Bool -> Exp -> Exp
maybeExp :: Bool -> Exp -> Exp
maybeExp Bool
may Exp
exp | Bool
may = Exp
fmapE Exp -> Exp -> Exp
`AppE` Exp
exp
| Bool
otherwise = Exp
exp
maybeTyp :: Bool -> Type -> Type
maybeTyp :: Bool -> Type -> Type
maybeTyp Bool
may Type
typ | Bool
may = Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Type
typ
| Bool
otherwise = Type
typ
entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue
entityToPersistValueHelper :: record -> PersistValue
entityToPersistValueHelper record
entity = [(Text, PersistValue)] -> PersistValue
PersistMap ([(Text, PersistValue)] -> PersistValue)
-> [(Text, PersistValue)] -> PersistValue
forall a b. (a -> b) -> a -> b
$ [Text] -> [PersistValue] -> [(Text, PersistValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
columnNames [PersistValue]
fieldsAsPersistValues
where
columnNames :: [Text]
columnNames = (FieldDef -> Text) -> [FieldDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell) (EntityDef -> [FieldDef]
getEntityFields (Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (record -> Maybe record
forall a. a -> Maybe a
Just record
entity)))
fieldsAsPersistValues :: [PersistValue]
fieldsAsPersistValues = (SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue ([SomePersistField] -> [PersistValue])
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> a -> b
$ record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
entity
entityFromPersistValueHelper
:: (PersistEntity record)
=> [String]
-> PersistValue
-> Either Text record
entityFromPersistValueHelper :: [String] -> PersistValue -> Either Text record
entityFromPersistValueHelper [String]
columnNames PersistValue
pv = do
([(Text, PersistValue)]
persistMap :: [(T.Text, PersistValue)]) <- PersistValue -> Either Text [(Text, PersistValue)]
getPersistMap PersistValue
pv
let columnMap :: HashMap Text PersistValue
columnMap = [(Text, PersistValue)] -> HashMap Text PersistValue
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, PersistValue)]
persistMap
lookupPersistValueByColumnName :: String -> PersistValue
lookupPersistValueByColumnName :: String -> PersistValue
lookupPersistValueByColumnName String
columnName =
PersistValue -> Maybe PersistValue -> PersistValue
forall a. a -> Maybe a -> a
fromMaybe PersistValue
PersistNull (Text -> HashMap Text PersistValue -> Maybe PersistValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (String -> Text
pack String
columnName) HashMap Text PersistValue
columnMap)
[PersistValue] -> Either Text record
forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues ([PersistValue] -> Either Text record)
-> [PersistValue] -> Either Text record
forall a b. (a -> b) -> a -> b
$ (String -> PersistValue) -> [String] -> [PersistValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PersistValue
lookupPersistValueByColumnName [String]
columnNames
persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps UnboundEntityDef
entDef = do
Exp
sqlStringConstructor' <- [|SqlString|]
Exp
toPersistValueImplementation <- [|entityToPersistValueHelper|]
Exp
fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ
[ Name -> [Clause] -> Dec
FunD 'toPersistValue [ [Pat] -> Exp -> Clause
normalClause [] Exp
toPersistValueImplementation ]
, Name -> [Clause] -> Dec
FunD 'fromPersistValue
[ [Pat] -> Exp -> Clause
normalClause [] Exp
fromPersistValueImplementation ]
]
, Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ
[ Exp -> Dec
sqlTypeFunD Exp
sqlStringConstructor'
]
]
where
typ :: Type
typ =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)) Type
backendT
entFields :: [UnboundFieldDef]
entFields =
(UnboundFieldDef -> Bool) -> [UnboundFieldDef] -> [UnboundFieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter UnboundFieldDef -> Bool
isHaskellUnboundField ([UnboundFieldDef] -> [UnboundFieldDef])
-> [UnboundFieldDef] -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
columnNames :: [String]
columnNames =
(UnboundFieldDef -> String) -> [UnboundFieldDef] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> String
unpack (Text -> String)
-> (UnboundFieldDef -> Text) -> UnboundFieldDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> (UnboundFieldDef -> FieldNameHS) -> UnboundFieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS) [UnboundFieldDef]
entFields
share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec]
share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec]
share [[a] -> Q [Dec]]
fs [a]
x = [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([a] -> Q [Dec]) -> Q [Dec]) -> [[a] -> Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([a] -> Q [Dec]) -> [a] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [a]
x) [[a] -> Q [Dec]]
fs
mkSave :: String -> [EntityDef] -> Q [Dec]
mkSave :: String -> [EntityDef] -> Q [Dec]
mkSave String
name' [EntityDef]
defs' = do
let name :: Name
name = String -> Name
mkName String
name'
Exp
defs <- [EntityDef] -> Q Exp
forall t. Lift t => t -> Q Exp
lift [EntityDef]
defs'
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Type -> Dec
SigD Name
name (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Type
ListT Type -> Type -> Type
`AppT` Name -> Type
ConT ''EntityDef
, Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Exp -> Clause
normalClause [] Exp
defs]
]
{-# DEPRECATED mkSave "This function is broken. mkEntityDefList is a drop-in replacement that will properly handle foreign keys correctly." #-}
data Dep = Dep
{ Dep -> EntityNameHS
depTarget :: EntityNameHS
, Dep -> EntityNameHS
depSourceTable :: EntityNameHS
, Dep -> FieldNameHS
depSourceField :: FieldNameHS
, Dep -> IsNullable
depSourceNull :: IsNullable
}
{-# DEPRECATED mkDeleteCascade "You can now set update and delete cascade behavior directly on the entity in the quasiquoter. This function and class are deprecated and will be removed in the next major ersion." #-}
mkDeleteCascade :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
mkDeleteCascade :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
mkDeleteCascade MkPersistSettings
mps [UnboundEntityDef]
defs = do
let deps :: [Dep]
deps = (UnboundEntityDef -> [Dep]) -> [UnboundEntityDef] -> [Dep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnboundEntityDef -> [Dep]
getDeps [UnboundEntityDef]
defs
(UnboundEntityDef -> Q Dec) -> [UnboundEntityDef] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Dep] -> UnboundEntityDef -> Q Dec
go [Dep]
deps) [UnboundEntityDef]
defs
where
getDeps :: UnboundEntityDef -> [Dep]
getDeps :: UnboundEntityDef -> [Dep]
getDeps UnboundEntityDef
def =
(UnboundFieldDef -> [Dep]) -> [UnboundFieldDef] -> [Dep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnboundFieldDef -> [Dep]
getDeps' ([UnboundFieldDef] -> [Dep]) -> [UnboundFieldDef] -> [Dep]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs (UnboundEntityDef -> [UnboundFieldDef])
-> UnboundEntityDef -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> UnboundEntityDef
fixEntityDef UnboundEntityDef
def
where
getDeps' :: UnboundFieldDef -> [Dep]
getDeps' :: UnboundFieldDef -> [Dep]
getDeps' UnboundFieldDef
field =
case UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference UnboundFieldDef
field of
Just EntityNameHS
name ->
Dep -> [Dep]
forall (m :: * -> *) a. Monad m => a -> m a
return Dep :: EntityNameHS -> EntityNameHS -> FieldNameHS -> IsNullable -> Dep
Dep
{ depTarget :: EntityNameHS
depTarget = EntityNameHS
name
, depSourceTable :: EntityNameHS
depSourceTable = EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)
, depSourceField :: FieldNameHS
depSourceField = UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
field
, depSourceNull :: IsNullable
depSourceNull = UnboundFieldDef -> IsNullable
isUnboundFieldNullable UnboundFieldDef
field
}
Maybe EntityNameHS
Nothing ->
[]
go :: [Dep] -> UnboundEntityDef -> Q Dec
go :: [Dep] -> UnboundEntityDef -> Q Dec
go [Dep]
allDeps UnboundEntityDef
ued = do
let name :: EntityNameHS
name = EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ued)
let deps :: [Dep]
deps = (Dep -> Bool) -> [Dep] -> [Dep]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Dep
x -> Dep -> EntityNameHS
depTarget Dep
x EntityNameHS -> EntityNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== EntityNameHS
name) [Dep]
allDeps
Name
key <- String -> Q Name
newName String
"key"
let del :: Exp
del = Name -> Exp
VarE 'delete
let dcw :: Exp
dcw = Name -> Exp
VarE 'deleteCascadeWhere
Exp
just <- [|Just|]
Exp
filt <- [|Filter|]
Exp
eq <- [|Eq|]
Exp
value <- [|FilterValue|]
let mkStmt :: Dep -> Stmt
mkStmt :: Dep -> Stmt
mkStmt Dep
dep = Exp -> Stmt
NoBindS
(Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp
dcw Exp -> Exp -> Exp
`AppE`
[Exp] -> Exp
ListE
[ Exp
filt Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
filtName
Exp -> Exp -> Exp
`AppE` (Exp
value Exp -> Exp -> Exp
`AppE` IsNullable -> Exp
val (Dep -> IsNullable
depSourceNull Dep
dep))
Exp -> Exp -> Exp
`AppE` Exp
eq
]
where
filtName :: Name
filtName = MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps (Dep -> EntityNameHS
depSourceTable Dep
dep) (Dep -> FieldNameHS
depSourceField Dep
dep)
val :: IsNullable -> Exp
val (Nullable WhyNullable
ByMaybeAttr) = Exp
just Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
key
val IsNullable
_ = Name -> Exp
VarE Name
key
let stmts :: [Stmt]
stmts :: [Stmt]
stmts = (Dep -> Stmt) -> [Dep] -> [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dep -> Stmt
mkStmt [Dep]
deps [Stmt] -> [Stmt] -> [Stmt]
forall m. Monoid m => m -> m -> m
`mappend`
[Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp
del Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
key]
let entityT :: Type
entityT = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
name Type
backendT
Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> [Dec] -> Dec
instanceD
[ Name -> [Type] -> Type
mkClassP ''PersistQuery [Type
backendT]
, Type -> Type -> Type
mkEqualP (Name -> Type
ConT ''PersistEntityBackend Type -> Type -> Type
`AppT` Type
entityT) (Name -> Type
ConT ''BaseBackend Type -> Type -> Type
`AppT` Type
backendT)
]
(Name -> Type
ConT ''DeleteCascade Type -> Type -> Type
`AppT` Type
entityT Type -> Type -> Type
`AppT` Type
backendT)
[ Name -> [Clause] -> Dec
FunD 'deleteCascade
[[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
key] ([Stmt] -> Exp
mkDoE [Stmt]
stmts)]
]
mkEntityDefList
:: String
-> [UnboundEntityDef]
-> Q [Dec]
mkEntityDefList :: String -> [UnboundEntityDef] -> Q [Dec]
mkEntityDefList String
entityList [UnboundEntityDef]
entityDefs = do
let entityListName :: Name
entityListName = String -> Name
mkName String
entityList
Exp
edefs <- ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE
(Q [Exp] -> Q Exp)
-> ((UnboundEntityDef -> Q Exp) -> Q [Exp])
-> (UnboundEntityDef -> Q Exp)
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnboundEntityDef] -> (UnboundEntityDef -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnboundEntityDef]
entityDefs
((UnboundEntityDef -> Q Exp) -> Q Exp)
-> (UnboundEntityDef -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \UnboundEntityDef
entDef ->
let entityType :: Q Type
entityType = UnboundEntityDef -> Q Type
entityDefConT UnboundEntityDef
entDef
in [|entityDef (Proxy :: Proxy $(entityType))|]
Type
typ <- [t|[EntityDef]|]
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
SigD Name
entityListName Type
typ
, Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
entityListName) (Exp -> Body
NormalB Exp
edefs) []
]
mkUniqueKeys :: UnboundEntityDef -> Q Dec
mkUniqueKeys :: UnboundEntityDef -> Q Dec
mkUniqueKeys UnboundEntityDef
def | EntityDef -> Bool
entitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def) =
Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] ([Exp] -> Exp
ListE [])]
mkUniqueKeys UnboundEntityDef
def = do
Clause
c <- Q Clause
clause
Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [Clause
c]
where
clause :: Q Clause
clause = do
[(FieldNameHS, Name)]
xs <- [UnboundFieldDef]
-> (UnboundFieldDef -> Q (FieldNameHS, Name))
-> Q [(FieldNameHS, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
def) ((UnboundFieldDef -> Q (FieldNameHS, Name))
-> Q [(FieldNameHS, Name)])
-> (UnboundFieldDef -> Q (FieldNameHS, Name))
-> Q [(FieldNameHS, Name)]
forall a b. (a -> b) -> a -> b
$ \UnboundFieldDef
fieldDef -> do
let x :: FieldNameHS
x = UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef
Name
x' <- String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
unpack (FieldNameHS -> Text
unFieldNameHS FieldNameHS
x)
(FieldNameHS, Name) -> Q (FieldNameHS, Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldNameHS
x, Name
x')
let pcs :: [Exp]
pcs = (UniqueDef -> Exp) -> [UniqueDef] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(FieldNameHS, Name)] -> UniqueDef -> Exp
go [(FieldNameHS, Name)]
xs) ([UniqueDef] -> [Exp]) -> [UniqueDef] -> [Exp]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques (EntityDef -> [UniqueDef]) -> EntityDef -> [UniqueDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def
let pat :: Pat
pat = Name -> [Pat] -> Pat
conp
(UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
def)
(((FieldNameHS, Name) -> Pat) -> [(FieldNameHS, Name)] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Pat
VarP (Name -> Pat)
-> ((FieldNameHS, Name) -> Name) -> (FieldNameHS, Name) -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, Name) -> Name
forall a b. (a, b) -> b
snd) [(FieldNameHS, Name)]
xs)
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] ([Exp] -> Exp
ListE [Exp]
pcs)
go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
go [(FieldNameHS, Name)]
xs (UniqueDef ConstraintNameHS
name ConstraintNameDB
_ NonEmpty ForeignFieldDef
cols [Text]
_) =
(Exp -> FieldNameHS -> Exp) -> Exp -> [FieldNameHS] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' [(FieldNameHS, Name)]
xs) (Name -> Exp
ConE (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
name)) (NonEmpty FieldNameHS -> [FieldNameHS]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ (ForeignFieldDef -> FieldNameHS)
-> NonEmpty ForeignFieldDef -> NonEmpty FieldNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldDef -> FieldNameHS
forall a b. (a, b) -> a
fst NonEmpty ForeignFieldDef
cols)
go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' [(FieldNameHS, Name)]
xs Exp
front FieldNameHS
col =
let Just Name
col' = FieldNameHS -> [(FieldNameHS, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FieldNameHS
col [(FieldNameHS, Name)]
xs
in Exp
front Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
col'
sqlTypeFunD :: Exp -> Dec
sqlTypeFunD :: Exp -> Dec
sqlTypeFunD Exp
st = Name -> [Clause] -> Dec
FunD 'sqlType
[ [Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
st ]
typeInstanceD
:: Name
-> Bool
-> Type
-> [Dec]
-> Dec
typeInstanceD :: Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD Name
clazz Bool
hasBackend Type
typ =
[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
ctx (Name -> Type
ConT Name
clazz Type -> Type -> Type
`AppT` Type
typ)
where
ctx :: [Type]
ctx
| Bool
hasBackend = [Name -> [Type] -> Type
mkClassP ''PersistStore [Type
backendT]]
| Bool
otherwise = []
persistFieldInstanceD :: Bool
-> Type -> [Dec] -> Dec
persistFieldInstanceD :: Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD = Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''PersistField
persistFieldSqlInstanceD :: Bool
-> Type -> [Dec] -> Dec
persistFieldSqlInstanceD :: Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD = Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''PersistFieldSql
derivePersistField :: String -> Q [Dec]
derivePersistField :: String -> Q [Dec]
derivePersistField String
s = do
Exp
ss <- [|SqlString|]
Exp
tpv <- [|PersistText . pack . show|]
Exp
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'|]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD Bool
False (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
[ Name -> [Clause] -> Dec
FunD 'toPersistValue
[ [Pat] -> Exp -> Clause
normalClause [] Exp
tpv
]
, Name -> [Clause] -> Dec
FunD 'fromPersistValue
[ [Pat] -> Exp -> Clause
normalClause [] (Exp
fpv Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
s))
]
]
, Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD Bool
False (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
[ Exp -> Dec
sqlTypeFunD Exp
ss
]
]
derivePersistFieldJSON :: String -> Q [Dec]
derivePersistFieldJSON :: String -> Q [Dec]
derivePersistFieldJSON String
s = do
Exp
ss <- [|SqlString|]
Exp
tpv <- [|PersistText . toJsonText|]
Exp
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|]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD Bool
False (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
[ Name -> [Clause] -> Dec
FunD 'toPersistValue
[ [Pat] -> Exp -> Clause
normalClause [] Exp
tpv
]
, Name -> [Clause] -> Dec
FunD 'fromPersistValue
[ [Pat] -> Exp -> Clause
normalClause [] (Exp
fpv Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
s))
]
]
, Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD Bool
False (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
[ Exp -> Dec
sqlTypeFunD Exp
ss
]
]
migrateModels :: [EntityDef] -> Migration
migrateModels :: [EntityDef] -> Migration
migrateModels [EntityDef]
defs=
[EntityDef] -> (EntityDef -> Migration) -> Migration
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((EntityDef -> Bool) -> [EntityDef] -> [EntityDef]
forall a. (a -> Bool) -> [a] -> [a]
filter EntityDef -> Bool
isMigrated [EntityDef]
defs) ((EntityDef -> Migration) -> Migration)
-> (EntityDef -> Migration) -> Migration
forall a b. (a -> b) -> a -> b
$ \EntityDef
def ->
[EntityDef] -> EntityDef -> Migration
migrate [EntityDef]
defs EntityDef
def
where
isMigrated :: EntityDef -> Bool
isMigrated EntityDef
def = String -> Text
pack String
"no-migrate" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` EntityDef -> [Text]
entityAttrs EntityDef
def
mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec]
mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec]
mkMigrate String
fun [UnboundEntityDef]
eds = do
let entityDefListName :: String
entityDefListName = (String
"entityDefListFor" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fun)
Exp
body <- [| migrateModels $(varE (mkName entityDefListName)) |]
[Dec]
edList <- String -> [UnboundEntityDef] -> Q [Dec]
mkEntityDefList String
entityDefListName [UnboundEntityDef]
eds
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
edList [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<>
[ Name -> Type -> Dec
SigD (String -> Name
mkName String
fun) (Name -> Type
ConT ''Migration)
, Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
fun) [[Pat] -> Exp -> Clause
normalClause [] Exp
body]
]
data EntityFieldTH = EntityFieldTH
{ EntityFieldTH -> Con
entityFieldTHCon :: Con
, EntityFieldTH -> Clause
entityFieldTHClause :: Clause
}
mkField :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UnboundFieldDef -> Q EntityFieldTH
mkField :: MkPersistSettings
-> EntityMap
-> UnboundEntityDef
-> UnboundFieldDef
-> Q EntityFieldTH
mkField MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
et UnboundFieldDef
fieldDef = do
let
con :: Con
con =
[TyVarBndr] -> [Type] -> Con -> Con
ForallC
[]
[Type -> Type -> Type
mkEqualP (Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ") Type
fieldT]
(Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC Name
name []
fieldT :: Type
fieldT =
MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing
Exp
bod <- UnboundEntityDef -> FieldNameHS -> Q Exp
mkLookupEntityField UnboundEntityDef
et (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)
let cla :: Clause
cla = [Pat] -> Exp -> Clause
normalClause
[Name -> [Pat] -> Pat
conp Name
name []]
Exp
bod
EntityFieldTH -> Q EntityFieldTH
forall (m :: * -> *) a. Monad m => a -> m a
return (EntityFieldTH -> Q EntityFieldTH)
-> EntityFieldTH -> Q EntityFieldTH
forall a b. (a -> b) -> a -> b
$ Con -> Clause -> EntityFieldTH
EntityFieldTH Con
con Clause
cla
where
name :: Name
name = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps UnboundEntityDef
et UnboundFieldDef
fieldDef
mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
mkIdField MkPersistSettings
mps UnboundEntityDef
ued = do
let
entityName :: EntityNameHS
entityName =
UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ued
entityIdType :: Type
entityIdType
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
Name -> Type
ConT ''Key Type -> Type -> Type
`AppT` (
Name -> Type
ConT (EntityNameHS -> Name
mkEntityNameHSGenericName EntityNameHS
entityName)
Type -> Type -> Type
`AppT` Type
backendT
)
| Bool
otherwise =
Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName) String -> ShowS
forall m. Monoid m => m -> m -> m
++ String
"Id"
name :: Name
name =
MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps EntityNameHS
entityName (Text -> FieldNameHS
FieldNameHS Text
"Id")
Exp
clause <-
MkPersistSettings -> UnboundEntityDef -> Q Exp
fixPrimarySpec MkPersistSettings
mps UnboundEntityDef
ued
EntityFieldTH -> Q EntityFieldTH
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntityFieldTH :: Con -> Clause -> EntityFieldTH
EntityFieldTH
{ entityFieldTHCon :: Con
entityFieldTHCon =
[TyVarBndr] -> [Type] -> Con -> Con
ForallC
[]
[Type -> Type -> Type
mkEqualP (Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ") Type
entityIdType]
(Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC Name
name []
, entityFieldTHClause :: Clause
entityFieldTHClause =
[Pat] -> Exp -> Clause
normalClause [Name -> [Pat] -> Pat
conp Name
name []] Exp
clause
}
lookupEntityField
:: PersistEntity entity
=> Proxy entity
-> FieldNameHS
-> FieldDef
lookupEntityField :: Proxy entity -> FieldNameHS -> FieldDef
lookupEntityField Proxy entity
prxy FieldNameHS
fieldNameHS =
FieldDef -> Maybe FieldDef -> FieldDef
forall a. a -> Maybe a -> a
fromMaybe FieldDef
forall a. a
boom (Maybe FieldDef -> FieldDef) -> Maybe FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Bool) -> [FieldDef] -> Maybe FieldDef
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((FieldNameHS
fieldNameHS FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
==) (FieldNameHS -> Bool)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell) ([FieldDef] -> Maybe FieldDef) -> [FieldDef] -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields (EntityDef -> [FieldDef]) -> EntityDef -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ Proxy entity -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef Proxy entity
prxy
where
boom :: a
boom =
String -> a
forall a. HasCallStack => String -> a
error String
"Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name"
mkLookupEntityField
:: UnboundEntityDef
-> FieldNameHS
-> Q Exp
mkLookupEntityField :: UnboundEntityDef -> FieldNameHS -> Q Exp
mkLookupEntityField UnboundEntityDef
ued FieldNameHS
ufd =
[|
lookupEntityField
(Proxy :: Proxy $(conT entityName))
$(lift ufd)
|]
where
entityName :: Name
entityName = EntityNameHS -> Name
mkEntityNameHSName (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ued)
maybeNullable :: UnboundFieldDef -> Bool
maybeNullable :: UnboundFieldDef -> Bool
maybeNullable UnboundFieldDef
fd = UnboundFieldDef -> IsNullable
isUnboundFieldNullable UnboundFieldDef
fd IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
== WhyNullable -> IsNullable
Nullable WhyNullable
ByMaybeAttr
ftToType :: FieldType -> Type
ftToType :: FieldType -> Type
ftToType = \case
FTTypeCon Maybe Text
Nothing Text
t ->
Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
FTTypeCon (Just Text
"Data.Int") Text
"Int64" ->
Name -> Type
ConT ''Int64
FTTypeCon (Just Text
m) Text
t ->
Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
concat [Text
m, Text
".", Text
t]
FTTypePromoted Text
t ->
Name -> Type
PromotedT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
FTApp FieldType
x FieldType
y ->
FieldType -> Type
ftToType FieldType
x Type -> Type -> Type
`AppT` FieldType -> Type
ftToType FieldType
y
FTList FieldType
x ->
Type
ListT Type -> Type -> Type
`AppT` FieldType -> Type
ftToType FieldType
x
infixr 5 ++
(++) :: Monoid m => m -> m -> m
++ :: m -> m -> m
(++) = m -> m -> m
forall m. Monoid m => m -> m -> m
mappend
mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON MkPersistSettings
_ UnboundEntityDef
def | (Text
"json" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` EntityDef -> [Text]
entityAttrs (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)) = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkJSON MkPersistSettings
mps (UnboundEntityDef -> UnboundEntityDef
fixEntityDef -> UnboundEntityDef
def) = do
[[Extension]] -> Q ()
requireExtensions [[Extension
FlexibleInstances]]
Exp
pureE <- [|pure|]
Exp
apE' <- [|(<*>)|]
let objectE :: Exp
objectE = Name -> Exp
VarE 'object
withObjectE :: Exp
withObjectE = Name -> Exp
VarE 'withObject
dotEqualE :: Exp
dotEqualE = Name -> Exp
VarE '(.=)
dotColonE :: Exp
dotColonE = Name -> Exp
VarE '(.:)
dotColonQE :: Exp
dotColonQE = Name -> Exp
VarE '(.:?)
#if MIN_VERSION_aeson(2,0,0)
toKeyE :: Exp
toKeyE = Name -> Exp
VarE 'Key.fromString
#else
toKeyE = VarE 'pack
#endif
Name
obj <- String -> Q Name
newName String
"obj"
let
fields :: [UnboundFieldDef]
fields =
UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
def
[Name]
xs <- (UnboundFieldDef -> Q Name) -> [UnboundFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UnboundFieldDef -> Q Name
fieldToJSONValName [UnboundFieldDef]
fields
let
conName :: Name
conName =
UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
def
typ :: Type
typ =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)) Type
backendT
toJSONI :: Dec
toJSONI =
Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''ToJSON (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ [Dec
toJSON']
where
toJSON' :: Dec
toJSON' = Name -> [Clause] -> Dec
FunD 'toJSON ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
[Name -> [Pat] -> Pat
conp Name
conName ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
xs]
(Exp
objectE Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
pairs)
where
pairs :: [Exp]
pairs = (UnboundFieldDef -> Name -> Exp)
-> [UnboundFieldDef] -> [Name] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith UnboundFieldDef -> Name -> Exp
toPair [UnboundFieldDef]
fields [Name]
xs
toPair :: UnboundFieldDef -> Name -> Exp
toPair UnboundFieldDef
f Name
x = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp
toKeyE Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text) -> FieldNameHS -> Text
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
f)))
Exp
dotEqualE
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x)
fromJSONI :: Dec
fromJSONI =
Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''FromJSON (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ [Dec
parseJSON']
where
entNameStrLit :: Lit
entNameStrLit =
String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (EntityNameHS -> Text
unEntityNameHS (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
def))
parseJSONBody :: Exp
parseJSONBody =
Exp
withObjectE Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE Lit
entNameStrLit Exp -> Exp -> Exp
`AppE` Exp
decoderImpl
parseJSON' :: Dec
parseJSON' =
Name -> [Clause] -> Dec
FunD 'parseJSON [ [Pat] -> Exp -> Clause
normalClause [] Exp
parseJSONBody ]
decoderImpl :: Exp
decoderImpl =
[Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
obj]
((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
(\Exp
x Exp
y -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
x) Exp
apE' (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
y))
(Exp
pureE Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
conName)
[Exp]
pulls
)
where
pulls :: [Exp]
pulls =
(UnboundFieldDef -> Exp) -> [UnboundFieldDef] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundFieldDef -> Exp
toPull [UnboundFieldDef]
fields
toPull :: UnboundFieldDef -> Exp
toPull UnboundFieldDef
f = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
obj)
(if UnboundFieldDef -> Bool
maybeNullable UnboundFieldDef
f then Exp
dotColonQE else Exp
dotColonE)
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
toKeyE (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text) -> FieldNameHS -> Text
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
f)
case MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON MkPersistSettings
mps of
Maybe EntityJSON
Nothing ->
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
toJSONI, Dec
fromJSONI]
Just EntityJSON
entityJSON -> do
[Dec]
entityJSONIs <- if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
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))
|]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
toJSONI Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
fromJSONI Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
entityJSONIs
mkClassP :: Name -> [Type] -> Pred
mkClassP :: Name -> [Type] -> Type
mkClassP Name
cla [Type]
tys = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
cla) [Type]
tys
mkEqualP :: Type -> Type -> Pred
mkEqualP :: Type -> Type -> Type
mkEqualP Type
tleft Type
tright = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
EqualityT [Type
tleft, Type
tright]
notStrict :: Bang
notStrict :: Bang
notStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
isStrict :: Bang
isStrict :: Bang
isStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict
instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD :: [Type] -> Type -> [Dec] -> Dec
instanceD = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing
requirePersistentExtensions :: Q ()
requirePersistentExtensions :: Q ()
requirePersistentExtensions = [[Extension]] -> Q ()
requireExtensions [[Extension]]
requiredExtensions
where
requiredExtensions :: [[Extension]]
requiredExtensions = (Extension -> [Extension]) -> [Extension] -> [[Extension]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> [Extension]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Extension
DerivingStrategies
, Extension
GeneralizedNewtypeDeriving
, Extension
StandaloneDeriving
, Extension
UndecidableInstances
, Extension
MultiParamTypeClasses
]
mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkSymbolToFieldInstances MkPersistSettings
mps EntityMap
entityMap (UnboundEntityDef -> UnboundEntityDef
fixEntityDef -> UnboundEntityDef
ed) = do
let
entityHaskellName :: EntityNameHS
entityHaskellName =
EntityDef -> EntityNameHS
getEntityHaskellName (EntityDef -> EntityNameHS) -> EntityDef -> EntityNameHS
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ed
allFields :: [UnboundFieldDef]
allFields =
UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ed
mkEntityFieldConstr :: FieldNameHS -> Q Exp
mkEntityFieldConstr FieldNameHS
fieldHaskellName =
Name -> Q Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps EntityNameHS
entityHaskellName FieldNameHS
fieldHaskellName
:: Q Exp
[[Dec]]
regularFields <- [UnboundFieldDef] -> (UnboundFieldDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([UnboundFieldDef] -> [UnboundFieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [UnboundFieldDef]
allFields) ((UnboundFieldDef -> Q [Dec]) -> Q [[Dec]])
-> (UnboundFieldDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \UnboundFieldDef
fieldDef -> do
let
fieldHaskellName :: FieldNameHS
fieldHaskellName =
UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef
let fieldNameT :: Q Type
fieldNameT :: Q Type
fieldNameT =
TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> TyLitQ
strTyLit
(String -> TyLitQ) -> String -> TyLitQ
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall p. (Eq p, IsString p) => p -> p
lowerFirstIfId
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldHaskellName
lowerFirstIfId :: p -> p
lowerFirstIfId p
"Id" = p
"id"
lowerFirstIfId p
xs = p
xs
fieldTypeT :: Q Type
fieldTypeT
| FieldNameHS
fieldHaskellName FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"Id" =
Name -> Q Type
conT ''Key Q Type -> Q Type -> Q Type
`appT` Q Type
recordNameT
| Bool
otherwise =
Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing
entityFieldConstr :: Q Exp
entityFieldConstr =
FieldNameHS -> Q Exp
mkEntityFieldConstr FieldNameHS
fieldHaskellName
Q Type -> Q Type -> Q Exp -> Q [Dec]
mkInstance Q Type
fieldNameT Q Type
fieldTypeT Q Exp
entityFieldConstr
[Dec]
mkey <-
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
ed of
NaturalKey UnboundCompositeDef
_ ->
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
PrimarySpec
_ -> do
let
fieldHaskellName :: FieldNameHS
fieldHaskellName =
Text -> FieldNameHS
FieldNameHS Text
"Id"
entityFieldConstr :: Q Exp
entityFieldConstr =
FieldNameHS -> Q Exp
mkEntityFieldConstr FieldNameHS
fieldHaskellName
fieldTypeT :: Q Type
fieldTypeT =
Name -> Q Type
conT ''Key Q Type -> Q Type -> Q Type
`appT` Q Type
recordNameT
Q Type -> Q Type -> Q Exp -> Q [Dec]
mkInstance [t|"id"|] Q Type
fieldTypeT Q Exp
entityFieldConstr
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
mkey [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Dec]]
regularFields)
where
nameG :: Name
nameG =
UnboundEntityDef -> Name
mkEntityDefGenericName UnboundEntityDef
ed
recordNameT :: Q Type
recordNameT
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
Name -> Q Type
conT Name
nameG Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
backendName
| Bool
otherwise =
UnboundEntityDef -> Q Type
entityDefConT UnboundEntityDef
ed
mkInstance :: Q Type -> Q Type -> Q Exp -> Q [Dec]
mkInstance Q Type
fieldNameT Q Type
fieldTypeT Q Exp
entityFieldConstr =
[d|
instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where
symbolToField = $(entityFieldConstr)
|]
requireExtensions :: [[Extension]] -> Q ()
requireExtensions :: [[Extension]] -> Q ()
requireExtensions [[Extension]]
requiredExtensions = do
[[Extension]]
unenabledExtensions <- ([Extension] -> Q Bool) -> [[Extension]] -> Q [[Extension]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not (Bool -> Bool) -> ([Bool] -> Bool) -> [Bool] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or) (Q [Bool] -> Q Bool)
-> ([Extension] -> Q [Bool]) -> [Extension] -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extension -> Q Bool) -> [Extension] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Extension -> Q Bool
isExtEnabled) [[Extension]]
requiredExtensions
case ([Extension] -> Maybe Extension) -> [[Extension]] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Extension] -> Maybe Extension
forall a. [a] -> Maybe a
listToMaybe [[Extension]]
unenabledExtensions of
[] -> () -> Q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[Extension
extension] -> String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"Generating Persistent entities now requires the "
, Extension -> String
forall a. Show a => a -> String
show Extension
extension
, String
" language extension. Please enable it by copy/pasting this line to the top of your file:\n\n"
, Extension -> String
forall a. Show a => a -> String
extensionToPragma Extension
extension
]
[Extension]
extensions -> String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"Generating Persistent entities now requires the following language extensions:\n\n"
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" ((Extension -> String) -> [Extension] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> String
forall a. Show a => a -> String
show [Extension]
extensions)
, String
"\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" ((Extension -> String) -> [Extension] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> String
forall a. Show a => a -> String
extensionToPragma [Extension]
extensions)
]
where
extensionToPragma :: a -> String
extensionToPragma a
ext = String
"{-# LANGUAGE " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
ext String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" #-}"
fieldToJSONValName :: UnboundFieldDef -> Q Name
fieldToJSONValName :: UnboundFieldDef -> Q Name
fieldToJSONValName =
String -> Q Name
newName (String -> Q Name)
-> (UnboundFieldDef -> String) -> UnboundFieldDef -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (UnboundFieldDef -> Text) -> UnboundFieldDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHSForJSON (FieldNameHS -> Text)
-> (UnboundFieldDef -> FieldNameHS) -> UnboundFieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS
unFieldNameHSForJSON :: FieldNameHS -> Text
unFieldNameHSForJSON :: FieldNameHS -> Text
unFieldNameHSForJSON = Text -> Text
fixTypeUnderscore (Text -> Text) -> (FieldNameHS -> Text) -> FieldNameHS -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS
where
fixTypeUnderscore :: Text -> Text
fixTypeUnderscore = \case
Text
"type" -> Text
"type_"
Text
name -> Text
name
entityDefConK :: UnboundEntityDef -> Kind
entityDefConK :: UnboundEntityDef -> Type
entityDefConK = Name -> Type
conK (Name -> Type)
-> (UnboundEntityDef -> Name) -> UnboundEntityDef -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Name
mkEntityDefName
entityDefConT :: UnboundEntityDef -> Q Type
entityDefConT :: UnboundEntityDef -> Q Type
entityDefConT = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type)
-> (UnboundEntityDef -> Type) -> UnboundEntityDef -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Type
entityDefConK
entityDefConE :: UnboundEntityDef -> Exp
entityDefConE :: UnboundEntityDef -> Exp
entityDefConE = Name -> Exp
ConE (Name -> Exp)
-> (UnboundEntityDef -> Name) -> UnboundEntityDef -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Name
mkEntityDefName
fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef FieldNameHS
fieldName =
MkPersistSettings
-> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
mkRecordName MkPersistSettings
mps Maybe Text
mUnderscore (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)) FieldNameHS
fieldName
where
mUnderscore :: Maybe Text
mUnderscore
| MkPersistSettings -> Bool
mpsGenerateLenses MkPersistSettings
mps = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"_"
| Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef =
MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)
mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef =
MkPersistSettings
-> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
mkRecordName MkPersistSettings
mps Maybe Text
forall a. Maybe a
Nothing (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)) (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)
mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
mkRecordName :: MkPersistSettings
-> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
mkRecordName MkPersistSettings
mps Maybe Text
prefix EntityNameHS
entNameHS FieldNameHS
fieldNameHS =
String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
lowerFirst Text
recName
where
recName :: Text
recName :: Text
recName
| MkPersistSettings -> Bool
mpsPrefixFields MkPersistSettings
mps = MkPersistSettings -> Text -> Text -> Text
mpsFieldLabelModifier MkPersistSettings
mps Text
entityNameText (Text -> Text
upperFirst Text
fieldNameText)
| Bool
otherwise = Text
fieldNameText
entityNameText :: Text
entityNameText :: Text
entityNameText =
EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHS
fieldNameText :: Text
fieldNameText :: Text
fieldNameText =
FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldNameHS
mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name]
mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name]
mkEntityDefDeriveNames MkPersistSettings
mps UnboundEntityDef
entDef =
let
entityInstances :: [Name]
entityInstances =
String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Name) -> [Text] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityDef -> [Text]
entityDerives (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)
additionalInstances :: [Name]
additionalInstances =
(Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
entityInstances) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> [Name]
mpsDeriveInstances MkPersistSettings
mps
in
[Name]
entityInstances [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name]
additionalInstances
mkEntityNameHSName :: EntityNameHS -> Name
mkEntityNameHSName :: EntityNameHS -> Name
mkEntityNameHSName =
String -> Name
mkName (String -> Name)
-> (EntityNameHS -> String) -> EntityNameHS -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (EntityNameHS -> Text) -> EntityNameHS -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameHS -> Text
unEntityNameHS
mkEntityDefName :: UnboundEntityDef -> Name
mkEntityDefName :: UnboundEntityDef -> Name
mkEntityDefName =
EntityNameHS -> Name
mkEntityNameHSName (EntityNameHS -> Name)
-> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef
mkEntityDefGenericName :: UnboundEntityDef -> Name
mkEntityDefGenericName :: UnboundEntityDef -> Name
mkEntityDefGenericName =
EntityNameHS -> Name
mkEntityNameHSGenericName (EntityNameHS -> Name)
-> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef
mkEntityNameHSGenericName :: EntityNameHS -> Name
mkEntityNameHSGenericName :: EntityNameHS -> Name
mkEntityNameHSGenericName EntityNameHS
name =
String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (EntityNameHS -> Text
unEntityNameHS EntityNameHS
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Generic")
sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
unboundFieldDef =
String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
name
where
name :: Text
name
| MkPersistSettings -> Bool
mpsPrefixFields MkPersistSettings
mps = Text
modifiedName Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
"Sum"
| Bool
otherwise = Text
fieldName Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
"Sum"
fieldNameHS :: FieldNameHS
fieldNameHS =
UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
unboundFieldDef
modifiedName :: Text
modifiedName =
MkPersistSettings -> Text -> Text -> Text
mpsConstraintLabelModifier MkPersistSettings
mps Text
entityName Text
fieldName
entityName :: Text
entityName =
EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef
fieldName :: Text
fieldName =
Text -> Text
upperFirst (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldNameHS
mkConstraintName :: ConstraintNameHS -> Name
mkConstraintName :: ConstraintNameHS -> Name
mkConstraintName (ConstraintNameHS Text
name) =
String -> Name
mkName (Text -> String
T.unpack Text
name)
keyIdName :: UnboundEntityDef -> Name
keyIdName :: UnboundEntityDef -> Name
keyIdName = String -> Name
mkName (String -> Name)
-> (UnboundEntityDef -> String) -> UnboundEntityDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (UnboundEntityDef -> Text) -> UnboundEntityDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Text
keyIdText
keyIdText :: UnboundEntityDef -> Text
keyIdText :: UnboundEntityDef -> Text
keyIdText UnboundEntityDef
entDef = EntityNameHS -> Text
unEntityNameHS (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef) Text -> Text -> Text
forall m. Monoid m => m -> m -> m
`mappend` Text
"Id"
unKeyName :: UnboundEntityDef -> Name
unKeyName :: UnboundEntityDef -> Name
unKeyName UnboundEntityDef
entDef = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"un" Text -> Text -> Text
forall m. Monoid m => m -> m -> m
`mappend` UnboundEntityDef -> Text
keyText UnboundEntityDef
entDef
unKeyExp :: UnboundEntityDef -> Exp
unKeyExp :: UnboundEntityDef -> Exp
unKeyExp UnboundEntityDef
ent = Name -> Name -> Exp
fieldSel (UnboundEntityDef -> Name
keyConName UnboundEntityDef
ent) (UnboundEntityDef -> Name
unKeyName UnboundEntityDef
ent)
backendT :: Type
backendT :: Type
backendT = Name -> Type
VarT Name
backendName
backendName :: Name
backendName :: Name
backendName = String -> Name
mkName String
"backend"
keyConName :: UnboundEntityDef -> Name
keyConName :: UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef =
EntityNameHS -> [FieldNameHS] -> Name
keyConName'
(UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef)
(UnboundFieldDef -> FieldNameHS
unboundFieldNameHS (UnboundFieldDef -> FieldNameHS)
-> [UnboundFieldDef] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields (UnboundEntityDef
entDef))
keyConName' :: EntityNameHS -> [FieldNameHS] -> Name
keyConName' :: EntityNameHS -> [FieldNameHS] -> Name
keyConName' EntityNameHS
entName [FieldNameHS]
entFields = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
resolveConflict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
keyText' EntityNameHS
entName
where
resolveConflict :: Text -> Text
resolveConflict Text
kn = if Bool
conflict then Text
kn Text -> Text -> Text
forall m. Monoid m => m -> m -> m
`mappend` Text
"'" else Text
kn
conflict :: Bool
conflict = (FieldNameHS -> Bool) -> [FieldNameHS] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"key") [FieldNameHS]
entFields
keyConExp :: UnboundEntityDef -> Exp
keyConExp :: UnboundEntityDef -> Exp
keyConExp UnboundEntityDef
ed = Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> Name
keyConName UnboundEntityDef
ed
keyText :: UnboundEntityDef -> Text
keyText :: UnboundEntityDef -> Text
keyText UnboundEntityDef
entDef = EntityNameHS -> Text
unEntityNameHS (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef) Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
"Key"
keyText' :: EntityNameHS -> Text
keyText' :: EntityNameHS -> Text
keyText' EntityNameHS
entName = EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
"Key"
keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
keyFieldName MkPersistSettings
mps UnboundEntityDef
entDef FieldNameHS
fieldDef
| MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype MkPersistSettings
mps UnboundEntityDef
entDef =
UnboundEntityDef -> Name
unKeyName UnboundEntityDef
entDef
| Bool
otherwise =
String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
lowerFirst (UnboundEntityDef -> Text
keyText UnboundEntityDef
entDef) Text -> Text -> Text
forall m. Monoid m => m -> m -> m
`mappend` FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldDef
filterConName
:: MkPersistSettings
-> UnboundEntityDef
-> UnboundFieldDef
-> Name
filterConName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps (UnboundEntityDef -> EntityDef
unboundEntityDef -> EntityDef
entity) UnboundFieldDef
field =
MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entity) (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
field)
filterConName'
:: MkPersistSettings
-> EntityNameHS
-> FieldNameHS
-> Name
filterConName' :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps EntityNameHS
entity FieldNameHS
field = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
name
where
name :: Text
name
| FieldNameHS
field FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"Id" = Text
entityName Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
fieldName
| MkPersistSettings -> Bool
mpsPrefixFields MkPersistSettings
mps = Text
modifiedName
| Bool
otherwise = Text
fieldName
modifiedName :: Text
modifiedName = MkPersistSettings -> Text -> Text -> Text
mpsConstraintLabelModifier MkPersistSettings
mps Text
entityName Text
fieldName
entityName :: Text
entityName = EntityNameHS -> Text
unEntityNameHS EntityNameHS
entity
fieldName :: Text
fieldName = Text -> Text
upperFirst (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
field
discoverEntities :: Q Exp
discoverEntities :: Q Exp
discoverEntities = do
[Dec]
instances <- Name -> [Type] -> Q [Dec]
reifyInstances ''PersistEntity [Name -> Type
VarT (String -> Name
mkName String
"a")]
let
types :: [Type]
types =
(Dec -> Maybe Type) -> [Dec] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe Type
getDecType [Dec]
instances
getDecType :: Dec -> Maybe Type
getDecType Dec
dec =
case Dec
dec of
InstanceD Maybe Overlap
_moverlap [] Type
typ [Dec]
_decs ->
Type -> Maybe Type
stripPersistEntity Type
typ
Dec
_ ->
Maybe Type
forall a. Maybe a
Nothing
stripPersistEntity :: Type -> Maybe Type
stripPersistEntity Type
typ =
case Type
typ of
AppT (ConT Name
tyName) Type
t | Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''PersistEntity ->
Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
Type
_ ->
Maybe Type
forall a. Maybe a
Nothing
([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
[Type] -> (Type -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Type]
types ((Type -> Q Exp) -> Q [Exp]) -> (Type -> Q Exp) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Type
typ -> do
[e| entityDef (Proxy :: Proxy $(pure typ)) |]
setNull :: NonEmpty UnboundFieldDef -> Bool
setNull :: NonEmpty UnboundFieldDef -> Bool
setNull (UnboundFieldDef
fd :| [UnboundFieldDef]
fds) =
let
nullSetting :: Bool
nullSetting =
UnboundFieldDef -> Bool
isNull UnboundFieldDef
fd
isNull :: UnboundFieldDef -> Bool
isNull =
(IsNullable
NotNullable IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/=) (IsNullable -> Bool)
-> (UnboundFieldDef -> IsNullable) -> UnboundFieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> IsNullable
isUnboundFieldNullable
in
if (UnboundFieldDef -> Bool) -> [UnboundFieldDef] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Bool
nullSetting Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
==) (Bool -> Bool)
-> (UnboundFieldDef -> Bool) -> UnboundFieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> Bool
isNull) [UnboundFieldDef]
fds
then Bool
nullSetting
else String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$
String
"foreign key columns must all be nullable or non-nullable"
String -> ShowS
forall m. Monoid m => m -> m -> m
++ [Text] -> String
forall a. Show a => a -> String
show ((UnboundFieldDef -> Text) -> [UnboundFieldDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> (UnboundFieldDef -> FieldNameHS) -> UnboundFieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS) (UnboundFieldDef
fdUnboundFieldDef -> [UnboundFieldDef] -> [UnboundFieldDef]
forall a. a -> [a] -> [a]
:[UnboundFieldDef]
fds))