{-# 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
, mkPersistSettings
, sqlSettings
, mpsBackend
, mpsGeneric
, mpsPrefixFields
, mpsFieldLabelModifier
, mpsAvoidHsKeyword
, mpsConstraintLabelModifier
, mpsEntityHaddocks
, mpsEntityJSON
, mpsGenerateLenses
, mpsDeriveInstances
, mpsCamelCaseCompositeKeySelector
, EntityJSON(..)
, ImplicitIdDef
, setImplicitIdDef
, mkMigrate
, migrateModels
, discoverEntities
, 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(..)
, ToJSON(..)
, 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 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 (asum, toList)
import qualified Data.Set as Set
import Language.Haskell.TH.Lib
(appT, conE, conK, conT, litT, strTyLit, varE, varP, varT)
#if MIN_VERSION_template_haskell(2,21,0)
import Language.Haskell.TH.Lib (defaultBndrFlag)
#endif
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
import Web.PathPieces (PathPiece(..))
import Database.Persist
import Database.Persist.Class.PersistEntity
import Database.Persist.Quasi
import Database.Persist.Quasi.Internal
import Database.Persist.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 -> [Pat] -> Pat
conp Name
name [Pat]
pats = Name -> [Type] -> [Pat] -> Pat
ConP Name
name [] [Pat]
pats
#else
conp :: Name -> [Pat] -> Pat
conp = ConP
#endif
persistWith :: PersistSettings -> QuasiQuoter
persistWith :: PersistSettings -> QuasiQuoter
persistWith PersistSettings
ps = 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
ss <- (String -> Q Text) -> [String] -> Q [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO Text -> Q Text
forall a. IO a -> Q a
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 -> [Text] -> Text
T.intercalate Text
"\n" [Text]
ss
parseReferences ps s
getFileContents :: FilePath -> IO Text
getFileContents :: String -> IO Text
getFileContents = (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
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 a b. (a -> b) -> [a] -> [b]
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 =
overEntityFields
(fmap (setEmbedField (entityHaskell ent) embedEntityMap))
ent
}
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps Text
s = [UnboundEntityDef] -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => [UnboundEntityDef] -> m 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
liftAndFixKeys
:: MkPersistSettings
-> M.Map EntityNameHS a
-> EntityMap
-> UnboundEntityDef
-> Q Exp
liftAndFixKeys :: forall a.
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 =
$([Exp] -> Exp
ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnboundFieldDef -> Q Exp) -> [UnboundFieldDef] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse UnboundFieldDef -> Q Exp
combinedFixFieldDef [UnboundFieldDef]
fields)
, entityId =
$(MkPersistSettings -> UnboundEntityDef -> Q Exp
fixPrimarySpec MkPersistSettings
mps UnboundEntityDef
unboundEnt)
, entityForeigns =
$([UnboundForeignDef] -> Q Exp
fixUnboundForeignDefs (UnboundEntityDef -> [UnboundForeignDef]
unboundForeignDefs UnboundEntityDef
unboundEnt))
}
|]
where
fixUnboundForeignDefs
:: [UnboundForeignDef]
-> Q Exp
fixUnboundForeignDefs :: [UnboundForeignDef] -> Q Exp
fixUnboundForeignDefs [UnboundForeignDef]
fdefs =
([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
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
unboundForeignFields :: UnboundForeignFieldList
unboundForeignDef :: ForeignDef
unboundForeignDef :: UnboundForeignDef -> ForeignDef
unboundForeignFields :: UnboundForeignDef -> UnboundForeignFieldList
..} =
[|
unboundForeignDef
{ foreignFields =
$([(ForeignFieldDef, ForeignFieldDef)] -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *).
Quote m =>
[(ForeignFieldDef, ForeignFieldDef)] -> m Exp
lift [(ForeignFieldDef, ForeignFieldDef)]
fixForeignFields)
, foreignNullable =
$(Bool -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Bool -> m Exp
lift Bool
fixForeignNullable)
, foreignRefTableDBName =
$(EntityNameDB -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => EntityNameDB -> m Exp
lift EntityNameDB
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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
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 a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty FieldNameHS
ffns
FieldListHasReferences NonEmpty ForeignFieldReference
references ->
NonEmpty (ForeignFieldDef, ForeignFieldDef)
-> [(ForeignFieldDef, ForeignFieldDef)]
forall a. NonEmpty a -> [a]
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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldNameHS]
fieldNames Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty ForeignFieldDef -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty 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: "
, NonEmpty FieldNameHS -> String
forall a. Show a => a -> String
show ((ForeignFieldDef -> FieldNameHS)
-> NonEmpty ForeignFieldDef -> NonEmpty FieldNameHS
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldDef -> FieldNameHS
forall a b. (a, b) -> a
fst NonEmpty 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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
fieldStore) [FieldNameHS]
fieldNames) (NonEmpty ForeignFieldDef -> [ForeignFieldDef]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty ForeignFieldDef
parentKeyFieldNames)
where
parentKeyFieldNames
:: NonEmpty (FieldNameHS, FieldNameDB)
parentKeyFieldNames :: NonEmpty ForeignFieldDef
parentKeyFieldNames =
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
parentDef of
NaturalKey UnboundCompositeDef
ucd ->
(FieldNameHS -> ForeignFieldDef)
-> NonEmpty FieldNameHS -> NonEmpty ForeignFieldDef
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
parentFieldStore) (UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
SurrogateKey UnboundIdDef
uid ->
ForeignFieldDef -> NonEmpty ForeignFieldDef
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FieldNameHS
FieldNameHS Text
"Id", UnboundIdDef -> FieldNameDB
unboundIdDBName UnboundIdDef
uid)
DefaultKey FieldNameDB
dbName ->
ForeignFieldDef -> NonEmpty ForeignFieldDef
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
ffrSourceField :: ForeignFieldReference -> FieldNameHS
ffrSourceField :: FieldNameHS
ffrTargetField :: FieldNameHS
ffrTargetField :: 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
unboundFieldNameHS :: FieldNameHS
unboundFieldNameDB :: FieldNameDB
unboundFieldAttrs :: [FieldAttr]
unboundFieldStrict :: Bool
unboundFieldType :: FieldType
unboundFieldCascade :: FieldCascade
unboundFieldGenerated :: Maybe Text
unboundFieldComments :: Maybe Text
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
..} =
[|
FieldDef
{ fieldHaskell =
unboundFieldNameHS
, fieldDB =
unboundFieldNameDB
, fieldType =
unboundFieldType
, fieldSqlType =
$(Q Exp
sqlTyp')
, fieldAttrs =
unboundFieldAttrs
, fieldStrict =
unboundFieldStrict
, fieldReference =
$(Q Exp
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 ->
let targetTableQualified :: EntityNameHS
targetTableQualified =
EntityNameHS -> Maybe EntityNameHS -> EntityNameHS
forall a. a -> Maybe a -> a
fromMaybe EntityNameHS
targetTable (UnboundFieldDef -> Maybe EntityNameHS
guessFieldReferenceQualified UnboundFieldDef
ufd)
in (ReferenceDef -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => ReferenceDef -> m Exp
lift (EntityNameHS -> ReferenceDef
ForeignRef EntityNameHS
targetTable), SqlTypeExp -> Q Exp
liftSqlTypeExp (EntityNameHS -> SqlTypeExp
SqlTypeReference EntityNameHS
targetTableQualified))
Maybe EntityNameHS
Nothing ->
(ReferenceDef -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => ReferenceDef -> m 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
{ 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 a b. (a -> b) -> [a] -> [b]
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
refName <- UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference UnboundFieldDef
fieldDef
ent <- M.lookup refName entityMap
pure $ entityHaskell $ 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 =
Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FieldType -> Maybe Text
guessReferenceText (FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just FieldType
ft)
where
checkIdSuffix :: Text -> Maybe Text
checkIdSuffix =
Text -> Text -> Maybe Text
T.stripSuffix Text
"Id"
guessReferenceText :: Maybe FieldType -> Maybe Text
guessReferenceText Maybe FieldType
mft =
[Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
[ do
FTTypeCon _ (checkIdSuffix -> Just tableName) <- Maybe FieldType
mft
pure tableName
, do
FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- Maybe FieldType
mft
pure tableName
, do
FTApp (FTTypeCon _ "Maybe") next <- Maybe FieldType
mft
guessReferenceText (Just next)
]
guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReferenceQualified = FieldType -> Maybe EntityNameHS
guessReferenceQualified (FieldType -> Maybe EntityNameHS)
-> (UnboundFieldDef -> FieldType)
-> UnboundFieldDef
-> Maybe EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldType
unboundFieldType
guessReferenceQualified :: FieldType -> Maybe EntityNameHS
guessReferenceQualified :: FieldType -> Maybe EntityNameHS
guessReferenceQualified FieldType
ft =
Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FieldType -> Maybe Text
guessReferenceText (FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just FieldType
ft)
where
checkIdSuffix :: Text -> Maybe Text
checkIdSuffix =
Text -> Text -> Maybe Text
T.stripSuffix Text
"Id"
guessReferenceText :: Maybe FieldType -> Maybe Text
guessReferenceText Maybe FieldType
mft =
[Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
[ do
FTTypeCon mmod (checkIdSuffix -> Just tableName) <- Maybe FieldType
mft
pure $ maybe tableName (\Text
qualName -> Text
qualName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName) mmod
, do
FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- Maybe FieldType
mft
pure $ maybe tableName (\Text
qualName -> Text
qualName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName) mmod
, do
FTApp (FTTypeCon _ "Maybe") next <- Maybe FieldType
mft
guessReferenceText (Just next)
]
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 (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => EntityIdDef -> m 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 =
$(FieldNameDB -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => FieldNameDB -> m Exp
lift (FieldNameDB -> Q Exp) -> FieldNameDB -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldNameDB -> [FieldAttr] -> FieldNameDB
getSqlNameOr (UnboundIdDef -> FieldNameDB
unboundIdDBName UnboundIdDef
uid) (UnboundIdDef -> [FieldAttr]
unboundIdAttrs UnboundIdDef
uid))
, fieldType =
$(FieldType -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => FieldType -> m Exp
lift FieldType
fieldTyp)
, fieldSqlType =
$( SqlTypeExp -> Q Exp
liftSqlTypeExp (FieldType -> SqlTypeExp
SqlTypeExp FieldType
fieldTyp) )
, fieldStrict =
False
, fieldReference =
ForeignRef entNameHS
, fieldAttrs =
unboundIdAttrs uid
, fieldComments =
Nothing
, fieldCascade = unboundIdCascade uid
, fieldGenerated = Nothing
, fieldIsImplicitIdColumn = True
}
|]
NaturalKey UnboundCompositeDef
ucd ->
[| EntityIdNaturalKey $(UnboundEntityDef -> UnboundCompositeDef -> Q Exp
bindCompositeDef UnboundEntityDef
unboundEnt UnboundCompositeDef
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
fieldDefs <-
([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
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 (NonEmpty FieldNameHS -> [FieldNameHS]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ UnboundCompositeDef -> NonEmpty 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 :: forall a.
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 :: forall a.
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 -> String -> String
[SqlTypeExp] -> String -> String
SqlTypeExp -> String
(Int -> SqlTypeExp -> String -> String)
-> (SqlTypeExp -> String)
-> ([SqlTypeExp] -> String -> String)
-> Show SqlTypeExp
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SqlTypeExp -> String -> String
showsPrec :: Int -> SqlTypeExp -> String -> String
$cshow :: SqlTypeExp -> String
show :: SqlTypeExp -> String
$cshowList :: [SqlTypeExp] -> String -> String
showList :: [SqlTypeExp] -> String -> String
Show
liftSqlTypeExp :: SqlTypeExp -> Q Exp
liftSqlTypeExp :: SqlTypeExp -> Q Exp
liftSqlTypeExp SqlTypeExp
ste =
case SqlTypeExp
ste of
SqlType' SqlType
t ->
SqlType -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => SqlType -> m 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 a. a -> Q a
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Id"
[| sqlType (Proxy :: Proxy $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
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 a b. (a -> b) -> [a] -> [b]
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 :: forall a. Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity Map EntityNameHS a
allEntities FieldDef
field = do
let mfieldTy :: Maybe FieldType
mfieldTy = FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just (FieldType -> Maybe FieldType) -> FieldType -> Maybe FieldType
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
field
entName <- Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
[ do
FTTypeCon _ t <- Maybe FieldType
mfieldTy
stripSuffix "Id" t
, do
FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- Maybe FieldType
mfieldTy
pure entName
, do
FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- Maybe FieldType
mfieldTy
stripSuffix "Id" t
]
guard (M.member entName allEntities)
pure 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 a b. (a -> b) -> [a] -> [b]
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 -> String -> String
[FTTypeConDescr] -> String -> String
FTTypeConDescr -> String
(Int -> FTTypeConDescr -> String -> String)
-> (FTTypeConDescr -> String)
-> ([FTTypeConDescr] -> String -> String)
-> Show FTTypeConDescr
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FTTypeConDescr -> String -> String
showsPrec :: Int -> FTTypeConDescr -> String -> String
$cshow :: FTTypeConDescr -> String
show :: FTTypeConDescr -> String
$cshowList :: [FTTypeConDescr] -> String -> String
showList :: [FTTypeConDescr] -> String -> String
Show
mEmbedded
:: M.Map EntityNameHS a
-> FieldType
-> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded :: forall a.
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
mEmbedded Map EntityNameHS a
_ (FTLit FieldTypeLit
_) =
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 :: forall a.
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
refEntName <- Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
forall a. Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity Map EntityNameHS a
allEntities FieldDef
field
pure $ ForeignRef 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 = 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 a b. (a -> b) -> [a] -> [b]
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
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
requireExtensions
[ [TypeFamilies], [GADTs, ExistentialQuantification]
, [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving]
, [UndecidableInstances], [DataKinds], [FlexibleInstances]
]
persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents
entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents
jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents
uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents
safeToInsertInstances <- mconcat <$> mapM (mkSafeToInsertInstance mps) ents
symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents
return $ mconcat
[ persistFieldDecs
, entityDecs
, jsonDecs
, uniqueKeyInstances
, symbolToFieldInstances
, safeToInsertInstances
]
mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkSafeToInsertInstance MkPersistSettings
mps UnboundEntityDef
ued =
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
ued of
NaturalKey UnboundCompositeDef
_ ->
Q [Dec]
instanceOkay
SurrogateKey UnboundIdDef
uidDef -> do
let attrs :: [FieldAttr]
attrs =
UnboundIdDef -> [FieldAttr]
unboundIdAttrs UnboundIdDef
uidDef
isDefaultFieldAttr :: FieldAttr -> Bool
isDefaultFieldAttr = \case
FieldAttrDefault Text
_ ->
Bool
True
FieldAttr
_ ->
Bool
False
case UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
uidDef of
Maybe FieldType
Nothing ->
Q [Dec]
instanceOkay
Just FieldType
_ ->
case (FieldAttr -> Bool) -> [FieldAttr] -> Maybe FieldAttr
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find FieldAttr -> Bool
isDefaultFieldAttr [FieldAttr]
attrs of
Maybe FieldAttr
Nothing ->
Q [Dec]
badInstance
Just FieldAttr
_ -> do
instanceOkay
DefaultKey FieldNameDB
_ ->
Q [Dec]
instanceOkay
where
typ :: Type
typ :: Type
typ = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ued) Type
backendT
mkInstance :: Maybe Type -> Dec
mkInstance Maybe Type
merr =
Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing (([Type] -> [Type])
-> (Type -> [Type] -> [Type]) -> Maybe Type -> [Type] -> [Type]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Type] -> [Type]
forall a. a -> a
id (:) Maybe Type
merr [Type]
withPersistStoreWriteCxt) (Name -> Type
ConT ''SafeToInsert Type -> Type -> Type
`AppT` Type
typ) []
instanceOkay :: Q [Dec]
instanceOkay =
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Maybe Type -> Dec
mkInstance Maybe Type
forall a. Maybe a
Nothing
]
badInstance :: Q [Dec]
badInstance = do
err <- [t| TypeError (SafeToInsertErrorMessage $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) |]
pure
[ mkInstance (Just err)
]
withPersistStoreWriteCxt :: [Type]
withPersistStoreWriteCxt =
if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
then
[Name -> Type
ConT ''PersistStoreWrite Type -> Type -> Type
`AppT` Type
backendT]
else
[]
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode UnboundEntityDef
ed = do
mtyp <- String -> Q (Maybe Name)
lookupTypeName String
entityName
case mtyp of
Maybe Name
Nothing -> do
Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just Name
typeName -> do
instanceExists <- Name -> [Type] -> Q Bool
isInstance ''PersistEntity [Name -> Type
ConT Name
typeName]
pure (not 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 = f (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 =
iidFieldType iid (getEntityHaskellName ed)
, fieldSqlType =
iidFieldSqlType iid
, fieldAttrs =
let
def =
Maybe FieldAttr -> [FieldAttr]
forall a. Maybe a -> [a]
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 =
Maybe FieldAttr -> [FieldAttr]
forall a. Maybe a -> [a]
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
def <> maxlen <> fieldAttrs fd
, fieldIsImplicitIdColumn =
True
}
setToMpsDefault ImplicitIdDef
_ EntityIdDef
x =
EntityIdDef
x
fixEntityDef :: UnboundEntityDef -> UnboundEntityDef
fixEntityDef :: UnboundEntityDef -> UnboundEntityDef
fixEntityDef UnboundEntityDef
ued =
UnboundEntityDef
ued
{ unboundEntityFields =
filter isHaskellUnboundField (unboundEntityFields 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
mpsAvoidHsKeyword :: Text -> Text
, MkPersistSettings -> Text -> Text -> Text
mpsConstraintLabelModifier :: Text -> Text -> Text
, MkPersistSettings -> Bool
mpsEntityHaddocks :: Bool
, MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON :: Maybe EntityJSON
, MkPersistSettings -> Bool
mpsGenerateLenses :: Bool
, MkPersistSettings -> [Name]
mpsDeriveInstances :: [Name]
, MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef :: ImplicitIdDef
, MkPersistSettings -> Bool
mpsCamelCaseCompositeKeySelector :: Bool
}
{-# 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 = iid }
getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType = do
idDef <- MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef
isGeneric <- mpsGeneric
backendTy <- mpsBackend
pure $ iidType idDef isGeneric backendTy
data EntityJSON = EntityJSON
{ EntityJSON -> Name
entityToJSON :: Name
, EntityJSON -> Name
entityFromJSON :: Name
}
mkPersistSettings
:: Type
-> MkPersistSettings
mkPersistSettings :: Type -> MkPersistSettings
mkPersistSettings Type
backend = 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
(++)
, mpsAvoidHsKeyword :: Text -> Text
mpsAvoidHsKeyword = (Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
"_")
, mpsConstraintLabelModifier :: Text -> Text -> Text
mpsConstraintLabelModifier = Text -> Text -> Text
forall m. Monoid m => m -> m -> m
(++)
, mpsEntityHaddocks :: Bool
mpsEntityHaddocks = Bool
False
, mpsEntityJSON :: Maybe EntityJSON
mpsEntityJSON = EntityJSON -> Maybe EntityJSON
forall a. a -> Maybe a
Just EntityJSON
{ entityToJSON :: Name
entityToJSON = 'entityIdToJSON
, entityFromJSON :: Name
entityFromJSON = 'entityIdFromJSON
}
, mpsGenerateLenses :: Bool
mpsGenerateLenses = Bool
False
, mpsDeriveInstances :: [Name]
mpsDeriveInstances = []
, mpsImplicitIdDef :: ImplicitIdDef
mpsImplicitIdDef =
ImplicitIdDef
autoIncrementingInteger
, mpsCamelCaseCompositeKeySelector :: Bool
mpsCamelCaseCompositeKeySelector = Bool
False
}
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 a b. (a -> b) -> [a] -> [b]
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
stocks))
DerivClause -> [DerivClause]
forall a. a -> [a]
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 a b. (a -> b) -> [a] -> [b]
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
anyclasses))
DerivClause -> [DerivClause]
forall a. a -> [a]
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 a b. (a -> b) -> [a] -> [b]
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 a. [a] -> 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]]
let dec :: Dec
dec = [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
nameFinal [TyVarBndr BndrVis]
paramsFinal
Maybe Type
forall a. Maybe a
Nothing
[Con]
constrs
([DerivClause]
stockDerives [DerivClause] -> [DerivClause] -> [DerivClause]
forall a. Semigroup a => a -> a -> a
<> [DerivClause]
anyclassDerives)
#if MIN_VERSION_template_haskell(2,18,0)
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MkPersistSettings -> Bool
mpsEntityHaddocks MkPersistSettings
mps) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
[(VarBangType, Maybe Text)]
-> ((VarBangType, Maybe Text) -> Q ()) -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(VarBangType, Maybe Text)]
cols (((VarBangType, Maybe Text) -> Q ()) -> Q ())
-> ((VarBangType, Maybe Text) -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \((Name
name, Bang
_, Type
_), Maybe Text
maybeComments) -> do
case Maybe Text
maybeComments of
Just Text
comment -> Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
name) (Text -> String
unpack Text
comment)
Maybe Text
Nothing -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
case EntityDef -> Maybe Text
entityComments (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef) of
Just Text
doc -> do
Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
nameFinal) (Text -> String
unpack Text
doc)
Maybe Text
_ -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif
Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec
where
stratFor :: Name -> Either Name Name
stratFor Name
n =
if Name
n Name -> Set Name -> Bool
forall a. Eq a => a -> Set a -> 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 a b. (a -> b) -> [a] -> [b]
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 BndrVis]
paramsFinal)
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
( UnboundEntityDef -> Name
mkEntityDefGenericName UnboundEntityDef
entDef
, [ Name -> TyVarBndr BndrVis
mkPlainTV Name
backendName
]
)
| Bool
otherwise =
(UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef, [])
cols :: [(VarBangType, Maybe Text)]
cols :: [(VarBangType, Maybe Text)]
cols = do
fieldDef <- UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
let
recordNameE =
MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef
strictness =
if UnboundFieldDef -> Bool
unboundFieldStrict UnboundFieldDef
fieldDef
then Bang
isStrict
else Bang
notStrict
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
fieldComments =
UnboundFieldDef -> Maybe Text
unboundFieldComments UnboundFieldDef
fieldDef
pure ((recordNameE, strictness, fieldIdType), fieldComments)
constrs :: [Con]
constrs
| UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef = (UnboundFieldDef -> Con) -> [UnboundFieldDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
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, Maybe Text) -> VarBangType)
-> [(VarBangType, Maybe Text)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map (VarBangType, Maybe Text) -> VarBangType
forall a b. (a, b) -> a
fst [(VarBangType, Maybe Text)]
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 a b. (a -> b) -> [a] -> [b]
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 a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty BangType
types
where
types :: NonEmpty BangType
types =
(ForeignFieldDef -> BangType)
-> NonEmpty ForeignFieldDef -> NonEmpty BangType
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
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 a. Eq a => a -> [a] -> 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 Persistent disallows NULLables in an uniqueness "
, String
"constraint. The semantics of how NULL interacts with those constraints "
, String
"is non-trivial: most SQL implementations will not consider two NULL "
, String
"values to be equal for the purposes of an uniqueness constraint, "
, String
"allowing insertion of more than one row with a NULL value for the "
, String
"column in question. If you understand this feature of SQL and still "
, String
"intend to add a uniqueness constraint here, *** Use a \"!force\" "
, String
"attribute 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
typ <- EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
fieldDef
guard ((mpsGeneric mps))
pure $
ConT ''Key
`AppT` genericDataType mps typ (VarT $ fromMaybe backendName 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
fieldTypeNoId <- Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
fieldTypeText
_ <- M.lookup (EntityNameHS fieldTypeNoId) em
pure (T.unpack fieldTypeText)
case Maybe String
mmodelIdString of
Maybe String
Nothing ->
Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Type
forall a. Maybe a
Nothing
Just String
modelIdString -> do
mIdName <- String -> Q (Maybe Name)
lookupTypeName String
modelIdString
pure $ fmap _removeIdFromTypeSuffix 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
a <- Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
name
pure $
T.unpack $ mconcat
[ case mmodule of
Maybe Text
Nothing ->
Text
""
Just Text
m ->
[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
m, Text
"."]
, a
, "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
clauses <-
if Bool
isSum
then [Q Clause] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Clause -> [Clause]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Q Clause
go
return $ FunD 'toPersistFields clauses
where
go :: Q Clause
go :: Q Clause
go = do
xs <- [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
let name = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ed
pat = Name -> [Pat] -> Pat
conp Name
name ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
xs
sp <- [|toPersistValue|]
let bod = [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
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
return $ normalClause [pat] bod
fieldCount :: Int
fieldCount = [UnboundFieldDef] -> Int
forall a. [a] -> 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
enull <- [|PersistNull|]
let beforeCount = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
afterCount = Int
fieldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
idx
before = Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
beforeCount Exp
enull
after = Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
afterCount Exp
enull
x <- newName "x"
sp <- [|toPersistValue|]
let 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
]
return $ normalClause [conp name [VarP x]] body
mkToFieldNames :: [UniqueDef] -> Q Dec
mkToFieldNames :: [UniqueDef] -> Q Dec
mkToFieldNames [UniqueDef]
pairs = do
pairs' <- (UniqueDef -> Q Clause) -> [UniqueDef] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM UniqueDef -> Q Clause
forall {m :: * -> *}. Quote m => UniqueDef -> m Clause
go [UniqueDef]
pairs
return $ FunD 'persistUniqueToFieldNames $ degen pairs'
where
go :: UniqueDef -> m Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
names [Text]
_) = do
names' <- NonEmpty ForeignFieldDef -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => NonEmpty ForeignFieldDef -> m Exp
lift NonEmpty ForeignFieldDef
names
return $
normalClause
[RecP (mkConstraintName constr) []]
names'
mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues [UniqueDef]
pairs = do
pairs' <- (UniqueDef -> Q Clause) -> [UniqueDef] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM UniqueDef -> Q Clause
go [UniqueDef]
pairs
return $ FunD 'persistUniqueToValues $ degen pairs'
where
go :: UniqueDef -> Q Clause
go :: UniqueDef -> Q Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
names [Text]
_) = do
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)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty 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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x") NonEmpty ForeignFieldDef
names
let 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 a b. (a -> b) -> [a] -> [b]
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 a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
tpv <- [|toPersistValue|]
let bod = [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
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 a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
return $ normalClause [pat] 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 :: forall a c b. (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
nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
clauses <- mkClauses [] $ getUnboundFieldDefs entDef
return $ clauses `mappend` [normalClause [WildP] 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 a b. (a -> b) -> [a] -> [b]
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkClauses [UnboundFieldDef]
before (UnboundFieldDef
field:[UnboundFieldDef]
after) = do
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
let null' = Name -> [Pat] -> Pat
conp 'PersistNull []
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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
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 = 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
fs <- [|fromPersistValue $(return $ VarE x)|]
let 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 = [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))]) []
clauses <- mkClauses (field : before) after
return $ 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 :: forall s a b t. (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 a b. (a -> b) -> f a -> f b
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 -> [(Name, Pat)] -> 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
-> Q Exp
fieldUpd :: Name -> [Name] -> Exp -> Name -> Exp -> Q Exp
fieldUpd Name
con [Name]
names Exp
record Name
name Exp
new = do
pats <-
([[(Name, Pat)]] -> [(Name, Pat)])
-> Q [[(Name, Pat)]] -> Q [(Name, Pat)]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Name, Pat)]] -> [(Name, Pat)]
forall a. Monoid a => [a] -> a
mconcat (Q [[(Name, Pat)]] -> Q [(Name, Pat)])
-> Q [[(Name, Pat)]] -> Q [(Name, Pat)]
forall a b. (a -> b) -> a -> b
$ [Name] -> (Name -> Q [(Name, Pat)]) -> Q [[(Name, Pat)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names ((Name -> Q [(Name, Pat)]) -> Q [[(Name, Pat)]])
-> (Name -> Q [(Name, Pat)]) -> Q [[(Name, Pat)]]
forall a b. (a -> b) -> a -> b
$ \Name
k -> do
varName <- Name -> Pat
VarP (Name -> Pat) -> Q Name -> Q Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
k)
pure [(k, varName) | k /= name]
pure $ CaseE record
[ Match (RecP con pats) (NormalB 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
]
mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
mkLensClauses MkPersistSettings
mps UnboundEntityDef
entDef Type
_genDataType = do
lens' <- [|lensPTH|]
getId <- [|entityKey|]
setId <- [|\(Entity _ value) key -> Entity key value|]
getVal <- [|entityVal|]
dot <- [|(.)|]
keyVar <- newName "key"
valName <- newName "value"
xName <- newName "x"
let idClause = [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)
(idClause :) <$> if unboundEntitySum entDef
then pure $ fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)
else zipWithM (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames
where
fieldNames :: [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
-> Q Clause
toClause Exp
lens' Exp
getVal Exp
dot Name
keyVar Name
valName Name
xName UnboundFieldDef
fieldDef Name
fieldName = do
setter <- Q Exp
mkSetter
pure $ normalClause
[conp (filterConName mps entDef fieldDef) []]
(lens' `AppE` getter `AppE` 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)
mkSetter :: Q Exp
mkSetter = do
updExpr <- Name -> [Name] -> Exp -> Name -> Exp -> Q Exp
fieldUpd Name
defName [Name]
fieldNames (Name -> Exp
VarE Name
valName) Name
fieldName (Name -> Exp
VarE Name
xName)
pure $ LamE
[ conp 'Entity [VarP keyVar, VarP valName]
, VarP xName
]
$ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr
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 a. [a] -> 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
(instDecs, i) <-
if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
then if Bool -> Bool
not Bool
useNewtype
then do pfDec <- Q [Dec]
pfInstD
return (pfDec, supplement [''Generic])
else do gi <- Q [Dec]
genericNewtypeInstances
return (gi, supplement [])
else if Bool -> Bool
not Bool
useNewtype
then do pfDec <- Q [Dec]
pfInstD
return (pfDec, 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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Name]
allInstances)
else do
bi <- Q [Dec]
backendKeyI
return (bi, allInstances)
requirePersistentExtensions
let alwaysStockStrategyTypeclasses = [''Show, ''Read]
deriveClauses = (Name -> DerivClause) -> [Name] -> [DerivClause]
forall a b. (a -> b) -> [a] -> [b]
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 a. Eq a => a -> [a] -> 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 = 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
return (kd, 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) (NonEmpty VarBangType -> [VarBangType]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty VarBangType -> [VarBangType])
-> NonEmpty VarBangType -> [VarBangType]
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> UnboundEntityDef -> NonEmpty 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 $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType)) where
toPersistValue = PersistList . keyToValues
fromPersistValue (PersistList l) = keyFromValues l
fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got
instance PersistFieldSql (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType)) where
sqlType _ = SqlString
instance ToJSON (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
instance FromJSON (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
|]
backendKeyGenericI :: Q [Dec]
backendKeyGenericI =
[d| instance PersistStore $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT) =>
ToBackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType) where
toBackendKey = $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
unKeyE)
fromBackendKey = $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
keyConE)
|]
backendKeyI :: Q [Dec]
backendKeyI = let bdt :: Type
bdt = MkPersistSettings -> Type
backendDataType MkPersistSettings
mps in
[d| instance ToBackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
bdt) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType) where
toBackendKey = $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
unKeyE)
fromBackendKey = $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
keyConE)
|]
genericNewtypeInstances :: Q [Dec]
genericNewtypeInstances = do
Q ()
requirePersistentExtensions
alwaysInstances <-
[d|deriving stock instance Show (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => Show (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving stock instance Read (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => Read (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance Eq (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => Eq (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance Ord (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => Ord (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance ToHttpApiData (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => ToHttpApiData (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance FromHttpApiData (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => FromHttpApiData(Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance PathPiece (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => PathPiece (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance PersistField (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => PersistField (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance PersistFieldSql (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => PersistFieldSql (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance ToJSON (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => ToJSON (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
deriving newtype instance FromJSON (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT)) => FromJSON (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
|]
mappend alwaysInstances <$>
if customKeyType
then pure []
else 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 = NonEmpty VarBangType -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (MkPersistSettings -> UnboundEntityDef -> NonEmpty 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 -> NonEmpty (Name, Strict, Type)
keyFields :: MkPersistSettings -> UnboundEntityDef -> NonEmpty VarBangType
keyFields MkPersistSettings
mps UnboundEntityDef
entDef =
case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
NaturalKey UnboundCompositeDef
ucd ->
(FieldNameHS -> VarBangType)
-> NonEmpty FieldNameHS -> NonEmpty VarBangType
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldNameHS -> VarBangType
naturalKeyVar (UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
DefaultKey FieldNameDB
_ ->
VarBangType -> NonEmpty VarBangType
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarBangType -> NonEmpty VarBangType)
-> (Type -> VarBangType) -> Type -> NonEmpty VarBangType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar (Type -> NonEmpty VarBangType) -> Type -> NonEmpty VarBangType
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> Type
getImplicitIdType MkPersistSettings
mps
SurrogateKey UnboundIdDef
k ->
VarBangType -> NonEmpty VarBangType
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarBangType -> NonEmpty VarBangType)
-> (Type -> VarBangType) -> Type -> NonEmpty VarBangType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar (Type -> NonEmpty VarBangType) -> Type -> NonEmpty 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
recordN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"record"
FunD 'keyToValues . pure <$>
case unboundPrimarySpec entDef of
NaturalKey UnboundCompositeDef
ucd -> do
[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
recordN] (Exp -> Clause) -> Q Exp -> Q Clause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Name -> UnboundCompositeDef -> Q Exp
toValuesPrimary Name
recordN 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 . $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> Exp
unKeyExp UnboundEntityDef
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> FieldNameHS -> Q Exp
f Name
recName) (NonEmpty FieldNameHS -> [FieldNameHS]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
f :: Name -> FieldNameHS -> Q Exp
f Name
recName FieldNameHS
fieldNameHS =
[|
toPersistValue ($(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Exp
keyFieldSel FieldNameHS
fieldNameHS) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
recName))
|]
keyFieldSel :: FieldNameHS -> Exp
keyFieldSel FieldNameHS
name
= Name -> Name -> Exp
fieldSel (UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef) (MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
keyFieldName MkPersistSettings
mps UnboundEntityDef
entDef FieldNameHS
name)
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 (NonEmpty FieldNameHS -> [FieldNameHS]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
PrimarySpec
_ -> do
e <- [|fmap $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
keyConE) . fromPersistValue . headNote|]
return [normalClause [] 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 -> String -> String
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
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
let
funMsg =
[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ UnboundEntityDef -> Text
entityText UnboundEntityDef
entDef
, Text
": "
, Text
funName
, Text
" failed on: "
]
patternMatchFailure <-
[|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
suc <- patternSuccess
return [ suc, normalClause [VarP x] 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
rightE <- [|Right|]
return $ normalClause [ListP []] (rightE `AppE` constructExpr)
[FieldNameHS]
_ -> do
x1 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x1"
restNames <- mapM (\Int
i -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"x" String -> String -> String
forall m. Monoid m => m -> m -> m
`mappend` Int -> String
forall a. Show a => a -> String
show Int
i) [2..length fields]
(fpv1:mkPersistValues) <- mapM mkPersistValue fields
app1E <- [|(<$>)|]
let conApp = Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
app1E Exp
fpv1 Exp
constructExpr Name
x1
applyE <- [|(<*>)|]
let applyFromPersistValue = Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
applyE
return $ normalClause
[ListP $ fmap VarP (x1:restNames)]
(List.foldl' (\Exp
exp (Name
name, Exp
fpv) -> Exp -> Exp -> Name -> Exp
applyFromPersistValue Exp
fpv Exp
exp Name
name) conApp (zip restNames 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 :: forall a.
Map EntityNameHS a
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkEntity Map EntityNameHS a
embedEntityMap EntityMap
entityMap MkPersistSettings
mps UnboundEntityDef
preDef = do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EntityDef -> Bool
isEntitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
preDef)) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"persistent has deprecated sum type entities as of 2.14.0.0."
, String
"We will delete support for these entities in 2.15.0.0."
, String
"If you need these, please add a comment on this GitHub issue:"
, String
""
, String
" https://github.com/yesodweb/persistent/issues/987"
]
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 -> UnboundEntityDef
fixEntityDef UnboundEntityDef
preDef
fields <- mkFields mps entityMap entDef
let name = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef
let clazz = Name -> Type
ConT ''PersistEntity Type -> Type -> Type
`AppT` Type
genDataType
tpf <- mkToPersistFields mps entDef
fpv <- mkFromPersistValues mps entDef
utv <- mkUniqueToValues $ entityUniques $ unboundEntityDef entDef
puk <- mkUniqueKeys entDef
fkc <- mapM (mkForeignKeysComposite mps entDef) $ unboundForeignDefs entDef
toFieldNames <- mkToFieldNames $ entityUniques $ unboundEntityDef entDef
(keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef
keyToValues' <- mkKeyToValues mps entDef
keyFromValues' <- mkKeyFromValues mps entDef
let addSyn
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps = (:) (Dec -> [Dec] -> [Dec]) -> Dec -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$
Name -> [TyVarBndr BndrVis] -> 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
lensClauses <- mkLensClauses mps entDef genDataType
lenses <- mkLenses mps entityMap entDef
let instanceConstraint = if Bool -> Bool
not (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) then [] else
[Name -> [Type] -> Type
mkClassP ''PersistStore [Type
backendT]]
[keyFromRecordM'] <-
case unboundPrimarySpec entDef of
NaturalKey UnboundCompositeDef
ucd -> do
let keyFields' :: NonEmpty Name
keyFields' = MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef (FieldNameHS -> Name) -> NonEmpty FieldNameHS -> NonEmpty Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd
keyFieldNames' <- NonEmpty Name
-> (Name -> Q (Name, Name)) -> Q (NonEmpty (Name, Name))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty Name
keyFields' ((Name -> Q (Name, Name)) -> Q (NonEmpty (Name, Name)))
-> (Name -> Q (Name, Name)) -> Q (NonEmpty (Name, Name))
forall a b. (a -> b) -> a -> b
$ \Name
fieldName -> do
fieldVarName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
fieldName)
return (fieldName, fieldVarName)
let keyCon = UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef
constr =
(Exp -> Exp -> Exp) -> Exp -> NonEmpty Exp -> Exp
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
Exp -> Exp -> Exp
AppE
(Name -> Exp
ConE Name
keyCon)
(Name -> Exp
VarE (Name -> Exp) -> ((Name, Name) -> Name) -> (Name, Name) -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> Exp) -> NonEmpty (Name, Name) -> NonEmpty Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name, Name)
keyFieldNames')
keyFromRec = Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP 'keyFromRecordM
fieldPat = [(Name
fieldName, Name -> Pat
VarP Name
fieldVarName) | (Name
fieldName, Name
fieldVarName) <- NonEmpty (Name, Name) -> [(Name, Name)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Name, Name)
keyFieldNames']
lam = [Pat] -> Exp -> Exp
LamE [Name -> [(Name, Pat)] -> Pat
RecP Name
name [(Name, Pat)]
fieldPat ] Exp
constr
[d|
$(keyFromRec) = Just $(pure lam)
|]
PrimarySpec
_ ->
[d|$(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP 'keyFromRecordM) = Nothing|]
dtd <- dataTypeDec mps entityMap entDef
let
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 =
EntityFieldTH -> Clause
entityFieldTHClause (EntityFieldTH -> Clause) -> [EntityFieldTH] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityFieldsTH -> [EntityFieldTH]
efthAllFields EntityFieldsTH
fields
mkTabulateA <- do
fromFieldName <- newName "fromField"
let names'types =
((Name, Type) -> Bool) -> [(Name, Type)] -> [(Name, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name
n, Type
_) -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Name
mkName String
"Id") ([(Name, Type)] -> [(Name, Type)])
-> [(Name, Type)] -> [(Name, Type)]
forall a b. (a -> b) -> a -> b
$ (EntityFieldTH -> (Name, Type))
-> [EntityFieldTH] -> [(Name, Type)]
forall a b. (a -> b) -> [a] -> [b]
map (Con -> (Name, Type)
getConNameAndType (Con -> (Name, Type))
-> (EntityFieldTH -> Con) -> EntityFieldTH -> (Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityFieldTH -> Con
entityFieldTHCon) ([EntityFieldTH] -> [(Name, Type)])
-> [EntityFieldTH] -> [(Name, Type)]
forall a b. (a -> b) -> a -> b
$ EntityFieldsTH -> [EntityFieldTH]
entityFieldsTHFields EntityFieldsTH
fields
getConNameAndType = \case
ForallC [] [Type
EqualityT `AppT` Type
_ `AppT` Type
fieldTy] (NormalC Name
conName []) ->
(Name
conName, Type
fieldTy)
Con
other ->
String -> (Name, Type)
forall a. HasCallStack => String -> a
error (String -> (Name, Type)) -> String -> (Name, Type)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"persistent internal error: field constructor did not have xpected shape. \n"
, String
"Expected: \n"
, String
" ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n"
, String
"Got: \n"
, String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a. Show a => a -> String
show Con
other
]
mkEntityVal =
(Exp -> (Name, Type) -> Exp) -> Exp -> [(Name, Type)] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
(\Exp
acc (Name
n, Type
_) ->
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
acc)
(Name -> Exp
VarE '(<*>))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
fromFieldName Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
n))
)
(Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE (EntityNameHS -> Name
mkEntityNameHSName EntityNameHS
entName))
[(Name, Type)]
names'types
primaryKeyField =
(Name, Type) -> Name
forall a b. (a, b) -> a
fst ((Name, Type) -> Name) -> (Name, Type) -> Name
forall a b. (a -> b) -> a -> b
$ Con -> (Name, Type)
getConNameAndType (Con -> (Name, Type)) -> Con -> (Name, Type)
forall a b. (a -> b) -> a -> b
$ EntityFieldTH -> Con
entityFieldTHCon (EntityFieldTH -> Con) -> EntityFieldTH -> Con
forall a b. (a -> b) -> a -> b
$ EntityFieldsTH -> EntityFieldTH
entityFieldsTHPrimary EntityFieldsTH
fields
body <-
if isEntitySum $ unboundEntityDef entDef
then [| error "tabulateEntityA does not make sense for sum type" |]
else
[|
Entity
<$> $(varE fromFieldName) $(conE primaryKeyField)
<*> $(pure mkEntityVal)
|]
pure $
FunD 'tabulateEntityA
[ Clause [VarP fromFieldName] (NormalB body) []
]
return $ addSyn $
dtd : mconcat fkc `mappend`
( [ TySynD (keyIdName entDef) [] $
ConT ''Key `AppT` ConT name
, instanceD instanceConstraint clazz
[ uniqueTypeDec mps entityMap entDef
, keyTypeDec
, keyToValues'
, keyFromValues'
, keyFromRecordM'
, mkTabulateA
, FunD 'entityDef [normalClause [WildP] entityDefExp]
, tpf
, FunD 'fromPersistValues fpv
, toFieldNames
, utv
, puk
#if MIN_VERSION_template_haskell(2,15,0)
, DataInstD
[]
Nothing
(AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ"))
Nothing
allEntDefs
[]
#else
, DataInstD
[]
''EntityField
[ genDataType
, VarT $ mkName "typ"
]
Nothing
allEntDefs
[]
#endif
, FunD 'persistFieldDef allEntDefClauses
#if MIN_VERSION_template_haskell(2,15,0)
, TySynInstD
(TySynEqn
Nothing
(AppT (ConT ''PersistEntityBackend) genDataType)
(backendDataType mps))
#else
, TySynInstD
''PersistEntityBackend
(TySynEqn
[genDataType]
(backendDataType mps))
#endif
, FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)]
, FunD 'fieldLens lensClauses
]
] `mappend` lenses) `mappend` keyInstanceDecs
where
genDataType :: 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 :: EntityFieldsTH -> [EntityFieldTH]
entityFieldsTHPrimary :: EntityFieldsTH -> EntityFieldTH
entityFieldsTHPrimary :: EntityFieldTH
entityFieldsTHFields :: [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 =
go (entityFieldTHClause 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 :: HasCallStack => 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
{ 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 a b. Q (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a b. Q (a -> b) -> Q a -> Q b
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 a b. Q (a -> b) -> Q a -> Q b
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 a b. Q (a -> b) -> Q a -> Q b
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
write <- [t|PersistStoreWrite $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT) |]
pure [write]
else do
[Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
typeErrorNoneCtx :: Q [Type]
typeErrorNoneCtx = do
tyErr <- [t|TypeError (NoUniqueKeysError $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
genDataType))|]
(tyErr :) <$> withPersistStoreWriteCxt
typeErrorMultipleCtx :: Q [Type]
typeErrorMultipleCtx = do
tyErr <- [t|TypeError (MultipleUniqueKeysError $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
genDataType))|]
(tyErr :) <$> withPersistStoreWriteCxt
mkOnlyUniqueError :: Q Cxt -> Q [Dec]
mkOnlyUniqueError :: Q [Type] -> Q [Dec]
mkOnlyUniqueError Q [Type]
mkCtx = do
ctx <- Q [Type]
mkCtx
let impl = Name -> [Dec]
mkImpossible Name
onlyUniquePName
pure [instanceD ctx onlyOneUniqueKeyClass 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
cxt <- Q [Type]
typeErrorNoneCtx
pure [instanceD cxt atLeastOneUniqueKeyClass impl]
singleUniqueKey :: Q [Dec]
singleUniqueKey :: Q [Dec]
singleUniqueKey = do
expr <- [e| head . persistUniqueKeys|]
let impl = [Name -> [Clause] -> Dec
FunD Name
onlyUniquePName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
cxt <- withPersistStoreWriteCxt
pure [instanceD cxt onlyOneUniqueKeyClass 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
expr <- [e| NEL.fromList . persistUniqueKeys|]
let impl = [Name -> [Clause] -> Dec
FunD Name
requireUniquesPName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
cxt <- withPersistStoreWriteCxt
pure [instanceD cxt atLeastOneUniqueKeyClass 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 a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkLenses MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
ent = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
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
needleN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"needle"
setterN <- newName "setter"
fN <- newName "f"
aN <- newName "a"
yN <- newName "y"
let needle = Name -> Exp
VarE Name
needleN
setter = Name -> Exp
VarE Name
setterN
f = Name -> Exp
VarE Name
fN
a = Name -> Exp
VarE Name
aN
y = Name -> Exp
VarE Name
yN
fT = String -> Name
mkName String
"f"
backend1 = Name
backendName
backend2 = Name
backendName
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 =
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
backend =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ent) (Name -> Type
VarT Name
backend)
sT = Name -> Type
mkST Name
backend1
tT = Name -> Type
mkST Name
backend2
Type
t1 `arrow` Type
t2 = Type
ArrowT Type -> Type -> Type
`AppT` Type
t1 Type -> Type -> Type
`AppT` Type
t2
vars = Name -> TyVarBndr Specificity
mkForallTV Name
fT
TyVarBndr Specificity
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. a -> [a] -> [a]
: (if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps then [Name -> TyVarBndr Specificity
mkForallTV Name
backend1] else [])
fieldUpdClause <- fieldUpd (mkEntityDefName ent) fieldNames a fieldName y
return
[ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $
(aT `arrow` (VarT fT `AppT` bT)) `arrow`
(sT `arrow` (VarT fT `AppT` tT))
, FunD lensName $ return $ Clause
[VarP fN, VarP aN]
(NormalB $ fmapE
`AppE` setter
`AppE` (f `AppE` needle))
[ FunD needleN [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)]
, FunD setterN $ return $ normalClause
[VarP yN]
fieldUpdClause
]
]
where
fieldNames :: [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,21,0)
mkPlainTV
:: Name
-> TyVarBndr BndrVis
mkPlainTV :: Name -> TyVarBndr BndrVis
mkPlainTV Name
n = Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n BndrVis
forall flag. DefaultBndrFlag flag => flag
defaultBndrFlag
mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV Name
n = Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
SpecifiedSpec
#elif MIN_VERSION_template_haskell(2,17,0)
mkPlainTV
:: Name
-> TyVarBndr ()
mkPlainTV n = PlainTV n ()
mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV n = PlainTV n SpecifiedSpec
#else
mkPlainTV
:: Name
-> TyVarBndr
mkPlainTV = PlainTV
mkForallTV
:: Name
-> TyVarBndr
mkForallTV = mkPlainTV
#endif
mkForeignKeysComposite
:: MkPersistSettings
-> UnboundEntityDef
-> UnboundForeignDef
-> Q [Dec]
mkForeignKeysComposite :: 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 -> String -> String
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
recordVarName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"record_mkForeignKeysComposite"
let
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
recordVarName)
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
foreignFieldList =
case UnboundForeignFieldList
foreignFieldList of
FieldListImpliedId NonEmpty FieldNameHS
names ->
NonEmpty FieldNameHS
names
FieldListHasReferences NonEmpty ForeignFieldReference
refs ->
(ForeignFieldReference -> FieldNameHS)
-> NonEmpty ForeignFieldReference -> NonEmpty FieldNameHS
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> FieldNameHS
ffrSourceField NonEmpty ForeignFieldReference
refs
fldsE =
UnboundForeignFieldList -> NonEmpty Exp
getForeignNames (UnboundForeignFieldList -> NonEmpty Exp)
-> UnboundForeignFieldList -> NonEmpty Exp
forall a b. (a -> b) -> a -> b
$ (UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields UnboundForeignDef
foreignDef)
getForeignNames = \case
FieldListImpliedId NonEmpty FieldNameHS
xs ->
(FieldNameHS -> Exp) -> NonEmpty FieldNameHS -> NonEmpty Exp
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> Exp
mkFldR NonEmpty ForeignFieldReference
xs
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n
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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
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 -> Exp -> Exp) -> Exp -> NonEmpty Exp -> Exp
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.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 =
Name -> [Clause] -> Dec
FunD Name
fname [[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
recordVarName] Exp
mkKeyE]
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)
sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |]
pure
[ SigD fname sigTy
, fn
]
| Bool
otherwise =
[Dec] -> Q [Dec]
forall a. a -> Q a
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 :: forall record. PersistEntity record => 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 a b. (a -> b) -> [a] -> [b]
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
forall (proxy :: * -> *). proxy record -> EntityDef
entityDef (record -> Maybe record
forall a. a -> Maybe a
Just record
entity)))
fieldsAsPersistValues :: [PersistValue]
fieldsAsPersistValues = (PersistValue -> PersistValue) -> [PersistValue] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PersistValue -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue ([PersistValue] -> [PersistValue])
-> [PersistValue] -> [PersistValue]
forall a b. (a -> b) -> a -> b
$ record -> [PersistValue]
forall record. PersistEntity record => record -> [PersistValue]
toPersistFields record
entity
entityFromPersistValueHelper
:: (PersistEntity record)
=> [String]
-> PersistValue
-> Either Text record
entityFromPersistValueHelper :: forall record.
PersistEntity record =>
[String] -> PersistValue -> Either Text record
entityFromPersistValueHelper [String]
columnNames PersistValue
pv = do
(persistMap :: [(T.Text, PersistValue)]) <- PersistValue -> Either Text [(Text, PersistValue)]
getPersistMap PersistValue
pv
let 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
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)
fromPersistValues $ fmap lookupPersistValueByColumnName columnNames
persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps UnboundEntityDef
entDef = do
sqlStringConstructor' <- [|SqlString|]
toPersistValueImplementation <- [|entityToPersistValueHelper|]
fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|]
return
[ persistFieldInstanceD (mpsGeneric mps) typ
[ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ]
, FunD 'fromPersistValue
[ normalClause [] fromPersistValueImplementation ]
]
, persistFieldSqlInstanceD (mpsGeneric mps) typ
[ sqlTypeFunD sqlStringConstructor'
]
]
where
typ :: 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 a b. (a -> b) -> [a] -> [b]
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 :: forall a. [[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([a] -> Q [Dec]) -> [a] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [a]
x) [[a] -> Q [Dec]]
fs
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
edefs <- ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
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 $(Q Type
entityType))|]
typ <- [t|[EntityDef]|]
pure
[ SigD entityListName typ
, ValD (VarP entityListName) (NormalB edefs) []
]
mkUniqueKeys :: UnboundEntityDef -> Q Dec
mkUniqueKeys :: UnboundEntityDef -> Q Dec
mkUniqueKeys UnboundEntityDef
def | EntityDef -> Bool
entitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def) =
Dec -> Q Dec
forall a. a -> Q a
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
c <- Q Clause
clause
return $ FunD 'persistUniqueKeys [c]
where
clause :: Q Clause
clause = do
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
x' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Text -> String
unpack (FieldNameHS -> Text
unFieldNameHS FieldNameHS
x)
return (x, x')
let pcs = (UniqueDef -> Exp) -> [UniqueDef] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
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 = Name -> [Pat] -> Pat
conp
(UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
def)
(((FieldNameHS, Name) -> Pat) -> [(FieldNameHS, Name)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
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)
return $ normalClause [pat] (ListE 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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ([(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' [(FieldNameHS, Name)]
xs) (Name -> Exp
ConE (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
name)) (NonEmpty FieldNameHS -> [FieldNameHS]
forall a. NonEmpty a -> [a]
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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
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 col' :: Name
col' =
Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"failed in go' while looking up col=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldNameHS -> String
forall a. Show a => a -> String
show FieldNameHS
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
ss <- [|SqlString|]
tpv <- [|PersistText . pack . show|]
fpv <- [|\dt v ->
case fromPersistValue v of
Left e -> Left e
Right s' ->
case reads $ unpack s' of
(x, _):_ -> Right x
[] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|]
return
[ persistFieldInstanceD False (ConT $ mkName s)
[ FunD 'toPersistValue
[ normalClause [] tpv
]
, FunD 'fromPersistValue
[ normalClause [] (fpv `AppE` LitE (StringL s))
]
]
, persistFieldSqlInstanceD False (ConT $ mkName s)
[ sqlTypeFunD ss
]
]
derivePersistFieldJSON :: String -> Q [Dec]
derivePersistFieldJSON :: String -> Q [Dec]
derivePersistFieldJSON String
s = do
ss <- [|SqlString|]
tpv <- [|PersistText . toJsonText|]
fpv <- [|\dt v -> do
text <- fromPersistValue v
let bs' = TE.encodeUtf8 text
case eitherDecodeStrict' bs' of
Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs'
Right x -> Right x|]
return
[ persistFieldInstanceD False (ConT $ mkName s)
[ FunD 'toPersistValue
[ normalClause [] tpv
]
, FunD 'fromPersistValue
[ normalClause [] (fpv `AppE` LitE (StringL s))
]
]
, persistFieldSqlInstanceD False (ConT $ mkName s)
[ sqlTypeFunD ss
]
]
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fun)
body <- [| migrateModels $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
entityDefListName)) |]
edList <- mkEntityDefList entityDefListName eds
pure $ edList <>
[ SigD (mkName fun) (ConT ''Migration)
, FunD (mkName fun) [normalClause [] 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 Specificity] -> [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
bod <- UnboundEntityDef -> FieldNameHS -> Q Exp
mkLookupEntityField UnboundEntityDef
et (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)
let cla = [Pat] -> Exp -> Clause
normalClause
[Name -> [Pat] -> Pat
conp Name
name []]
Exp
bod
return $ EntityFieldTH con 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 -> String -> String
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")
clause <-
MkPersistSettings -> UnboundEntityDef -> Q Exp
fixPrimarySpec MkPersistSettings
mps UnboundEntityDef
ued
pure EntityFieldTH
{ entityFieldTHCon =
ForallC
[]
[mkEqualP (VarT $ mkName "typ") entityIdType]
$ NormalC name []
, entityFieldTHClause =
normalClause [conp name []] clause
}
lookupEntityField
:: PersistEntity entity
=> Proxy entity
-> FieldNameHS
-> FieldDef
lookupEntityField :: forall entity.
PersistEntity entity =>
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
forall (proxy :: * -> *). proxy entity -> 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 $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
entityName))
$(FieldNameHS -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => FieldNameHS -> m Exp
lift FieldNameHS
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]
FTLit FieldTypeLit
l ->
TyLit -> Type
LitT (FieldTypeLit -> TyLit
typeLitToTyLit FieldTypeLit
l)
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
typeLitToTyLit :: FieldTypeLit -> TyLit
typeLitToTyLit :: FieldTypeLit -> TyLit
typeLitToTyLit = \case
IntTypeLit Integer
n -> Integer -> TyLit
NumTyLit Integer
n
TextTypeLit Text
t -> String -> TyLit
StrTyLit (Text -> String
T.unpack Text
t)
infixr 5 ++
(++) :: Monoid m => m -> m -> m
++ :: forall m. Monoid 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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkJSON MkPersistSettings
mps (UnboundEntityDef -> UnboundEntityDef
fixEntityDef -> UnboundEntityDef
def) = do
[[Extension]] -> Q ()
requireExtensions [[Extension
FlexibleInstances]]
pureE <- [|pure|]
apE' <- [|(<*>)|]
let objectE = Name -> Exp
VarE 'object
withObjectE = Name -> Exp
VarE 'withObject
dotEqualE = Name -> Exp
VarE '(.=)
dotColonE = Name -> Exp
VarE '(.:)
dotColonQE = Name -> Exp
VarE '(.:?)
#if MIN_VERSION_aeson(2,0,0)
toKeyE = Name -> Exp
VarE 'Key.fromString
#else
toKeyE = VarE 'pack
#endif
obj <- newName "obj"
let
fields =
UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
def
xs <- mapM fieldToJSONValName fields
let
conName =
UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
def
typ =
MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)) Type
backendT
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 a. a -> [a]
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 a b. (a -> b) -> [a] -> [b]
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 =
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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.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 a b. (a -> b) -> [a] -> [b]
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 mpsEntityJSON mps of
Maybe EntityJSON
Nothing ->
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
toJSONI, Dec
fromJSONI]
Just EntityJSON
entityJSON -> do
entityJSONIs <- if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
then [d|
instance PersistStore $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT) => ToJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
toJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityToJSON EntityJSON
entityJSON))
instance PersistStore $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT) => FromJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
parseJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityFromJSON EntityJSON
entityJSON))
|]
else [d|
instance ToJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
toJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityToJSON EntityJSON
entityJSON))
instance FromJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
parseJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityFromJSON EntityJSON
entityJSON))
|]
return $ toJSONI : fromJSONI : entityJSONIs
mkClassP :: Name -> [Type] -> Pred
mkClassP :: Name -> [Type] -> Type
mkClassP Name
cla [Type]
tys = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> [Extension]
forall a. a -> [a]
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
forall (m :: * -> *). Quote m => Name -> m 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
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 a. [a] -> [a]
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 =
Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit
(String -> Q TyLit) -> String -> Q TyLit
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}. (Eq a, IsString a) => a -> a
lowerFirstIfId
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldHaskellName
lowerFirstIfId :: a -> a
lowerFirstIfId a
"Id" = a
"id"
lowerFirstIfId a
xs = a
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
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Key Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
recordNameT
| Bool
otherwise =
Type -> Q Type
forall a. a -> Q a
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
mkey <- do
let
fieldHaskellName =
Text -> FieldNameHS
FieldNameHS Text
"Id"
entityFieldConstr =
FieldNameHS -> Q Exp
mkEntityFieldConstr FieldNameHS
fieldHaskellName
fieldTypeT =
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Key Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
recordNameT
mkInstance [t|"id"|] fieldTypeT entityFieldConstr
pure (mkey <> join regularFields)
where
nameG :: Name
nameG =
UnboundEntityDef -> Name
mkEntityDefGenericName UnboundEntityDef
ed
recordNameT :: Q Type
recordNameT
| MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nameG Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m 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 $(Q Type
fieldNameT) $(Q Type
recordNameT) $(Q Type
fieldTypeT) where
symbolToField = $(Q Exp
entityFieldConstr)
|]
requireExtensions :: [[Extension]] -> Q ()
requireExtensions :: [[Extension]] -> Q ()
requireExtensions [[Extension]]
requiredExtensions = do
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 a b. (a -> b) -> Q a -> Q b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Extension -> Q Bool
isExtEnabled) [[Extension]]
requiredExtensions
case mapMaybe listToMaybe unenabledExtensions of
[] -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[Extension
extension] -> String -> Q ()
forall a. String -> Q a
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 a. String -> Q a
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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
ext String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" #-}"
fieldToJSONValName :: UnboundFieldDef -> Q Name
fieldToJSONValName :: UnboundFieldDef -> Q Name
fieldToJSONValName =
String -> Q Name
forall (m :: * -> *). Quote m => String -> m 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 a. a -> Q a
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 -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
avoidKeyword (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
avoidKeyword :: Text -> Text
avoidKeyword :: Text -> Text
avoidKeyword Text
name = if Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
haskellKeywords then MkPersistSettings -> Text -> Text
mpsAvoidHsKeyword MkPersistSettings
mps Text
name else Text
name
haskellKeywords :: Set.Set Text
haskellKeywords :: Set Text
haskellKeywords = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[Text
"case",Text
"class",Text
"data",Text
"default",Text
"deriving",Text
"do",Text
"else"
,Text
"if",Text
"import",Text
"in",Text
"infix",Text
"infixl",Text
"infixr",Text
"instance",Text
"let",Text
"module"
,Text
"newtype",Text
"of",Text
"then",Text
"type",Text
"where",Text
"_"
,Text
"foreign"
]
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` Text
fieldName
where
fieldName :: Text
fieldName = Text -> Text
modifyFieldName (FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldDef)
modifyFieldName :: Text -> Text
modifyFieldName =
if MkPersistSettings -> Bool
mpsCamelCaseCompositeKeySelector MkPersistSettings
mps then Text -> Text
upperFirst else Text -> Text
forall a. a -> a
id
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
instances <- Name -> [Type] -> Q [Dec]
reifyInstances ''PersistEntity [Name -> Type
VarT (String -> Name
mkName String
"a")]
let
types =
(Dec -> Maybe Type) -> [Dec] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe Type
getDecType [Dec]
instances
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
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
fmap ListE $
forM types $ \Type
typ -> do
[e| entityDef (Proxy :: Proxy $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
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 -> String -> String
forall m. Monoid m => m -> m -> m
++ [Text] -> String
forall a. Show a => a -> String
show ((UnboundFieldDef -> Text) -> [UnboundFieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
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))