{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- | This module provides the tools for defining your database schema and using
-- it to generate Haskell data types and migrations.
--
-- For documentation on the domain specific language used for defining database
-- models, see "Database.Persist.Quasi".
--
--
module Database.Persist.TH
    ( -- * Parse entity defs
      persistWith
    , persistUpperCase
    , persistLowerCase
    , persistFileWith
    , persistManyFileWith
      -- * Turn @EntityDef@s into types
    , mkPersist
    , mkPersistWith
      -- ** Configuring Entity Definition
    , MkPersistSettings
    , mkPersistSettings
    , sqlSettings
    -- *** Record Fields (for update/viewing settings)
    , mpsBackend
    , mpsGeneric
    , mpsPrefixFields
    , mpsFieldLabelModifier
    , mpsConstraintLabelModifier
    , mpsEntityJSON
    , mpsGenerateLenses
    , mpsDeriveInstances
    , mpsCamelCaseCompositeKeySelector
    , EntityJSON(..)
    -- ** Implicit ID Columns
    , ImplicitIdDef
    , setImplicitIdDef
      -- * Various other TH functions
    , mkMigrate
    , migrateModels
    , discoverEntities
    , mkEntityDefList
    , share
    , derivePersistField
    , derivePersistFieldJSON
    , persistFieldFromEntity
      -- * Internal
    , lensPTH
    , parseReferences
    , embedEntityDefs
    , fieldError
    , AtLeastOneUniqueKey(..)
    , OnlyOneUniqueKey(..)
    , pkNewtype
    ) where

-- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code
-- It's highly recommended to check the diff between master and your PR's generated code.

import Prelude hiding (concat, exp, splitAt, take, (++))

import Control.Monad
import Data.Aeson
       ( FromJSON(..)
       , ToJSON(..)
       , eitherDecodeStrict'
       , object
       , withObject
       , (.:)
       , (.:?)
       , (.=)
       )
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Key
#endif
import qualified Data.ByteString as BS
import Data.Char (toLower, toUpper)
import Data.Coerce
import Data.Data (Data)
import Data.Either
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.Ix (Ix)
import Data.List (foldl')
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import GHC.TypeLits
import Instances.TH.Lift ()
    -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text`
    -- instance on pre-1.2.4 versions of `text`
import Data.Foldable (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

-- | Converts a quasi-quoted syntax into a list of entity definitions, to be
-- used as input to the template haskell generation code (mkPersist).
persistWith :: PersistSettings -> QuasiQuoter
persistWith :: PersistSettings -> QuasiQuoter
persistWith PersistSettings
ps = QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp =
        PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
    , quotePat :: String -> Q Pat
quotePat =
        forall a. HasCallStack => String -> a
error String
"persistWith can't be used as pattern"
    , quoteType :: String -> Q Type
quoteType =
        forall a. HasCallStack => String -> a
error String
"persistWith can't be used as type"
    , quoteDec :: String -> Q [Dec]
quoteDec =
        forall a. HasCallStack => String -> a
error String
"persistWith can't be used as declaration"
    }

-- | Apply 'persistWith' to 'upperCaseSettings'.
persistUpperCase :: QuasiQuoter
persistUpperCase :: QuasiQuoter
persistUpperCase = PersistSettings -> QuasiQuoter
persistWith PersistSettings
upperCaseSettings

-- | Apply 'persistWith' to 'lowerCaseSettings'.
persistLowerCase :: QuasiQuoter
persistLowerCase :: QuasiQuoter
persistLowerCase = PersistSettings -> QuasiQuoter
persistWith PersistSettings
lowerCaseSettings

-- | Same as 'persistWith', but uses an external file instead of a
-- quasiquotation. The recommended file extension is @.persistentmodels@.
persistFileWith :: PersistSettings -> FilePath -> Q Exp
persistFileWith :: PersistSettings -> String -> Q Exp
persistFileWith PersistSettings
ps String
fp = PersistSettings -> [String] -> Q Exp
persistManyFileWith PersistSettings
ps [String
fp]

-- | Same as 'persistFileWith', but uses several external files instead of
-- one. Splitting your Persistent definitions into multiple modules can
-- potentially dramatically speed up compile times.
--
-- The recommended file extension is @.persistentmodels@.
--
-- ==== __Examples__
--
-- Split your Persistent definitions into multiple files (@models1@, @models2@),
-- then create a new module for each new file and run 'mkPersist' there:
--
-- @
-- -- Model1.hs
-- 'share'
--     ['mkPersist' 'sqlSettings']
--     $('persistFileWith' 'lowerCaseSettings' "models1")
-- @
-- @
-- -- Model2.hs
-- 'share'
--     ['mkPersist' 'sqlSettings']
--     $('persistFileWith' 'lowerCaseSettings' "models2")
-- @
--
-- Use 'persistManyFileWith' to create your migrations:
--
-- @
-- -- Migrate.hs
-- 'mkMigrate' "migrateAll"
--     $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"])
-- @
--
-- Tip: To get the same import behavior as if you were declaring all your models in
-- one file, import your new files @as Name@ into another file, then export @module Name@.
--
-- This approach may be used in the future to reduce memory usage during compilation,
-- but so far we've only seen mild reductions.
--
-- See <https://github.com/yesodweb/persistent/issues/778 persistent#778> and
-- <https://github.com/yesodweb/persistent/pull/791 persistent#791> for more details.
--
-- @since 2.5.4
persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp
persistManyFileWith :: PersistSettings -> [String] -> Q Exp
persistManyFileWith PersistSettings
ps [String]
fps = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile [String]
fps
    [Text]
ss <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
getFileContents) [String]
fps
    let s :: Text
s = Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
ss -- be tolerant of the user forgetting to put a line-break at EOF.
    PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps Text
s

getFileContents :: FilePath -> IO Text
getFileContents :: String -> IO Text
getFileContents = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile

-- | Takes a list of (potentially) independently defined entities and properly
-- links all foreign keys to reference the right 'EntityDef', tying the knot
-- between entities.
--
-- Allows users to define entities indepedently or in separate modules and then
-- fix the cross-references between them at runtime to create a 'Migration'.
--
-- @since 2.7.2
embedEntityDefs
    :: [EntityDef]
    -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist'
    -- call.
    --
    -- @since 2.13.0.0
    -> [UnboundEntityDef]
    -> [UnboundEntityDef]
embedEntityDefs :: [EntityDef] -> [UnboundEntityDef] -> [UnboundEntityDef]
embedEntityDefs [EntityDef]
eds = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
embedEntityDefsMap [EntityDef]
eds

embedEntityDefsMap
    :: [EntityDef]
    -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist'
    -- call.
    --
    -- @since 2.13.0.0
    -> [UnboundEntityDef]
    -> (EmbedEntityMap, [UnboundEntityDef])
embedEntityDefsMap :: [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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundEntityDef -> UnboundEntityDef
setEmbedEntity ([UnboundEntityDef]
rawEnts forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> UnboundEntityDef
unbindEntityDef [EntityDef]
existingEnts)
    setEmbedEntity :: UnboundEntityDef -> UnboundEntityDef
setEmbedEntity UnboundEntityDef
ubEnt =
        let
            ent :: EntityDef
ent = UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ubEnt
        in
            UnboundEntityDef
ubEnt
                { unboundEntityDef :: EntityDef
unboundEntityDef =
                    ([FieldDef] -> [FieldDef]) -> EntityDef -> EntityDef
overEntityFields
                        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a.
EntityNameHS -> Map EntityNameHS a -> FieldDef -> FieldDef
setEmbedField (EntityDef -> EntityNameHS
entityHaskell EntityDef
ent) EmbedEntityMap
embedEntityMap))
                        EntityDef
ent
                }


-- | Calls 'parse' to Quasi.parse individual entities in isolation
-- afterwards, sets references to other entities
--
-- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@
-- instead of @['EntityDef']@.
--
-- @since 2.5.3
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps Text
s = forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift 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 =
            $(ListE <$> traverse combinedFixFieldDef fields)
        , entityId =
            $(fixPrimarySpec mps unboundEnt)
        , entityForeigns =
            $(fixUnboundForeignDefs (unboundForeignDefs unboundEnt))
        }
    |]
  where
    fixUnboundForeignDefs
        :: [UnboundForeignDef]
        -> Q Exp
    fixUnboundForeignDefs :: [UnboundForeignDef] -> Q Exp
fixUnboundForeignDefs [UnboundForeignDef]
fdefs =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnboundForeignDef]
fdefs UnboundForeignDef -> Q Exp
fixUnboundForeignDef
      where
        fixUnboundForeignDef :: UnboundForeignDef -> Q Exp
fixUnboundForeignDef UnboundForeignDef{ForeignDef
UnboundForeignFieldList
unboundForeignDef :: UnboundForeignDef -> ForeignDef
unboundForeignFields :: UnboundForeignDef -> UnboundForeignFieldList
unboundForeignDef :: ForeignDef
unboundForeignFields :: UnboundForeignFieldList
..} =
            [|
            unboundForeignDef
                { foreignFields =
                    $(lift fixForeignFields)
                , foreignNullable =
                    $(lift fixForeignNullable)
                , foreignRefTableDBName =
                    $(lift fixForeignRefTableDBName)
                }
            |]
          where
            fixForeignRefTableDBName :: EntityNameDB
fixForeignRefTableDBName =
                EntityDef -> EntityNameDB
entityDB (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
parentDef)
            foreignFieldNames :: NonEmpty FieldNameHS
foreignFieldNames =
                case UnboundForeignFieldList
unboundForeignFields of
                    FieldListImpliedId NonEmpty FieldNameHS
ffns ->
                        NonEmpty FieldNameHS
ffns
                    FieldListHasReferences NonEmpty ForeignFieldReference
references ->
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> FieldNameHS
ffrSourceField NonEmpty ForeignFieldReference
references
            parentDef :: UnboundEntityDef
parentDef =
                case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
parentTableName EntityMap
entityMap of
                    Maybe UnboundEntityDef
Nothing ->
                        forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                        [ String
"Foreign table not defined: "
                        , 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty FieldNameHS
ffns
                    FieldListHasReferences NonEmpty ForeignFieldReference
references ->
                        forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef)
convReferences NonEmpty ForeignFieldReference
references
              where
                -- in this case, we're up against the implied ID of the parent
                -- dodgy assumption: columns are listed in the right order. we
                -- can't check this any more clearly right now.
                mkReferences :: [FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)]
mkReferences [FieldNameHS]
fieldNames
                    | forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldNameHS]
fieldNames forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty ForeignFieldDef
parentKeyFieldNames =
                        forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ 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        : "
                            , forall a. Show a => a -> String
show (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
unboundEnt)
                            , String
"\n  Foreign Table: "
                            , forall a. Show a => a -> String
show EntityNameHS
parentTableName
                            , String
"\n  Fields       : "
                            , forall a. Show a => a -> String
show [FieldNameHS]
fieldNames
                            , String
"\n  Parent fields: "
                            , forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst NonEmpty ForeignFieldDef
parentKeyFieldNames)
                            , String
"\n\nYou can use the References keyword to fix this."
                            ]
                    | Bool
otherwise =
                        forall a b. [a] -> [b] -> [(a, b)]
zip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
fieldStore) [FieldNameHS]
fieldNames) (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 ->
                                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 ->
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FieldNameHS
FieldNameHS Text
"Id", UnboundIdDef -> FieldNameDB
unboundIdDBName  UnboundIdDef
uid)
                            DefaultKey FieldNameDB
dbName ->
                                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
ffrTargetField :: ForeignFieldReference -> FieldNameHS
ffrTargetField :: FieldNameHS
ffrSourceField :: FieldNameHS
ffrSourceField :: ForeignFieldReference -> FieldNameHS
..} =
                    ( FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
fieldStore FieldNameHS
ffrSourceField
                    , FieldStore -> FieldNameHS -> ForeignFieldDef
withDbName FieldStore
parentFieldStore FieldNameHS
ffrTargetField
                    )
            fixForeignNullable :: Bool
fixForeignNullable =
                forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((IsNullable
NotNullable forall a. Eq a => a -> a -> 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 ->
                            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 ->
                        forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                            [ String
"findDBName: failed to fix dbname for: "
                            , forall a. Show a => a -> String
show FieldNameHS
fieldNameHS
                            ]
                    Just FieldNameDB
a->
                        FieldNameDB
a

    combinedFixFieldDef :: UnboundFieldDef -> Q Exp
    combinedFixFieldDef :: UnboundFieldDef -> Q Exp
combinedFixFieldDef ufd :: UnboundFieldDef
ufd@UnboundFieldDef{Bool
[FieldAttr]
Maybe Text
FieldNameHS
FieldNameDB
FieldCascade
FieldType
unboundFieldComments :: UnboundFieldDef -> Maybe Text
unboundFieldGenerated :: UnboundFieldDef -> Maybe Text
unboundFieldCascade :: UnboundFieldDef -> FieldCascade
unboundFieldType :: UnboundFieldDef -> FieldType
unboundFieldStrict :: UnboundFieldDef -> Bool
unboundFieldAttrs :: UnboundFieldDef -> [FieldAttr]
unboundFieldNameDB :: UnboundFieldDef -> FieldNameDB
unboundFieldNameHS :: UnboundFieldDef -> FieldNameHS
unboundFieldComments :: Maybe Text
unboundFieldGenerated :: Maybe Text
unboundFieldCascade :: FieldCascade
unboundFieldType :: FieldType
unboundFieldStrict :: Bool
unboundFieldAttrs :: [FieldAttr]
unboundFieldNameDB :: FieldNameDB
unboundFieldNameHS :: FieldNameHS
..} =
        [|
        FieldDef
            { fieldHaskell =
                unboundFieldNameHS
            , fieldDB =
                unboundFieldNameDB
            , fieldType =
                unboundFieldType
            , fieldSqlType =
                $(sqlTyp')
            , fieldAttrs =
                unboundFieldAttrs
            , fieldStrict =
                unboundFieldStrict
            , fieldReference =
                $(fieldRef')
            , fieldCascade =
                unboundFieldCascade
            , fieldComments =
                unboundFieldComments
            , fieldGenerated =
                unboundFieldGenerated
            , fieldIsImplicitIdColumn =
                False
            }
        |]
      where
        sqlTypeExp :: SqlTypeExp
sqlTypeExp =
            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
_ =
            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 ->
                    (forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (EntityNameHS -> ReferenceDef
ForeignRef EntityNameHS
targetTable), SqlTypeExp -> Q Exp
liftSqlTypeExp (EntityNameHS -> SqlTypeExp
SqlTypeReference EntityNameHS
targetTable))
                Maybe EntityNameHS
Nothing ->
                    (forall t (m :: * -> *). (Lift t, Quote m) => t -> 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 =
            forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                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
                    )
                )
                forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs
                forall a b. (a -> b) -> a -> b
$ UnboundEntityDef
ued
        , fieldStoreId :: Maybe FieldNameDB
fieldStoreId =
            case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
ued of
                NaturalKey UnboundCompositeDef
_ ->
                    forall a. Maybe a
Nothing
                SurrogateKey UnboundIdDef
fd ->
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ UnboundIdDef -> FieldNameDB
unboundIdDBName UnboundIdDef
fd
                DefaultKey FieldNameDB
n ->
                    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" forall a. Eq a => a -> a -> Bool
== FieldNameHS
name =
        FieldStore -> Maybe FieldNameDB
fieldStoreId FieldStore
fs
    | Bool
otherwise =
        UnboundFieldDef -> FieldNameDB
unboundFieldNameDB 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 =
    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
extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
fieldDef = do
    EntityNameHS
refName <- UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference UnboundFieldDef
fieldDef
    UnboundEntityDef
ent <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
refName EntityMap
entityMap
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent

guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference = FieldType -> Maybe EntityNameHS
guessReference 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FieldType -> Maybe Text
guessReferenceText (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 =
        forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
            [ do
                FTTypeCon Maybe Text
_ (Text -> Maybe Text
checkIdSuffix -> Just Text
tableName) <- Maybe FieldType
mft
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
tableName
            , do
                FTApp (FTTypeCon Maybe Text
_ Text
"Key") (FTTypeCon Maybe Text
_ Text
tableName) <- Maybe FieldType
mft
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
tableName
            , do
                FTApp (FTTypeCon Maybe Text
_ Text
"Maybe") FieldType
next <- Maybe FieldType
mft
                Maybe FieldType -> Maybe Text
guessReferenceText (forall a. a -> Maybe a
Just FieldType
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
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id FieldAttr -> FieldDef -> FieldDef
addFieldAttr (Text -> FieldAttr
FieldAttrDefault forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Text
iidDefault ImplicitIdDef
iid) forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id FieldAttr -> FieldDef -> FieldDef
addFieldAttr (Integer -> FieldAttr
FieldAttrMaxlen forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Integer
iidMaxLen ImplicitIdDef
iid) 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 ->
            forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall a b. (a -> b) -> a -> b
$ FieldDef -> EntityIdDef
EntityIdField 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 =
                    forall a. a -> Maybe a -> a
fromMaybe (EntityNameHS -> FieldType
mkKeyConType EntityNameHS
entNameHS) (UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
uid)
            [|
                EntityIdField
                    FieldDef
                        { fieldHaskell =
                            FieldNameHS "Id"
                        , fieldDB =
                            $(lift $ getSqlNameOr (unboundIdDBName uid) (unboundIdAttrs uid))
                        , fieldType =
                            $(lift fieldTyp)
                        , fieldSqlType =
                            $( liftSqlTypeExp (SqlTypeExp  fieldTyp) )
                        , fieldStrict =
                            False
                        , fieldReference =
                            ForeignRef entNameHS
                        , fieldAttrs =
                            unboundIdAttrs uid
                        , fieldComments =
                            Nothing
                        , fieldCascade = unboundIdCascade uid
                        , fieldGenerated = Nothing
                        , fieldIsImplicitIdColumn = True
                        }

                |]
        NaturalKey UnboundCompositeDef
ucd ->
            [| EntityIdNaturalKey $(bindCompositeDef unboundEnt ucd) |]
  where
    unboundHaskellName :: EntityNameHS
unboundHaskellName =
        UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
unboundEnt

bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
bindCompositeDef UnboundEntityDef
ued UnboundCompositeDef
ucd = do
    Exp
fieldDefs <-
       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd) 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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a.
Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
defaultSqlTypeExp Map EntityNameHS a
emEntities EntityMap
entityMap UnboundFieldDef
field)
        (SqlType -> SqlTypeExp
SqlType' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SqlType
SqlOther)
        (forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldAttr -> Maybe Text
attrSqlType forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs UnboundFieldDef
field)

-- In the case of embedding, there won't be any datatype created yet.
-- We just use SqlString, as the data will be serialized to JSON.
defaultSqlTypeExp :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
defaultSqlTypeExp :: forall a.
Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
defaultSqlTypeExp Map EntityNameHS a
emEntities EntityMap
entityMap UnboundFieldDef
field =
    case 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 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 forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
refName EntityMap
entityMap of
                        Maybe UnboundEntityDef
Nothing ->
                            -- error $ mconcat
                            --     [ "Failed to find model: "
                            --     , show refName
                            --     , " in entity list: \n"
                            --     ]
                            --     <> (unlines $ map show $ M.keys $ entityMap)
                            -- going to assume that it's fine, will reify it out
                            -- right later anyway)
                            FieldType -> SqlTypeExp
SqlTypeExp FieldType
ftype
                        -- A ForeignRef is blindly set to an Int64 in setEmbedField
                        -- correct that now
                        Just UnboundEntityDef
_ ->
                            EntityNameHS -> SqlTypeExp
SqlTypeReference EntityNameHS
refName
                Maybe EntityNameHS
_ ->
                    case FieldType
ftype of
                        -- In the case of lists, we always serialize to a string
                        -- value (via JSON).
                        --
                        -- Normally, this would be determined automatically by
                        -- SqlTypeExp. However, there's one corner case: if there's
                        -- a list of entity IDs, the datatype for the ID has not
                        -- yet been created, so the compiler will fail. This extra
                        -- clause works around this limitation.
                        FTList 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 -> forall a. a -> Maybe a
Just Text
x
    FieldAttr
_ -> forall a. Maybe a
Nothing

data SqlTypeExp
    = SqlTypeExp FieldType
    | SqlType' SqlType
    | SqlTypeReference EntityNameHS
    deriving Int -> SqlTypeExp -> ShowS
[SqlTypeExp] -> ShowS
SqlTypeExp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlTypeExp] -> ShowS
$cshowList :: [SqlTypeExp] -> ShowS
show :: SqlTypeExp -> String
$cshow :: SqlTypeExp -> String
showsPrec :: Int -> SqlTypeExp -> ShowS
$cshowsPrec :: Int -> SqlTypeExp -> ShowS
Show

liftSqlTypeExp :: SqlTypeExp -> Q Exp
liftSqlTypeExp :: SqlTypeExp -> Q Exp
liftSqlTypeExp SqlTypeExp
ste =
    case SqlTypeExp
ste of
        SqlType' SqlType
t ->
            forall t (m :: * -> *). (Lift t, Quote m) => t -> 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
            forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHs) forall a. Semigroup a => a -> a -> a
<> String
"Id"

            [| sqlType (Proxy :: Proxy $(conT entNameId)) |]


type EmbedEntityMap = M.Map EntityNameHS ()

constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap
constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap
constructEmbedEntityMap =
    forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\UnboundEntityDef
ent ->
                ( EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent)
                -- , toEmbedEntityDef (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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
field
    EntityNameHS
entName <- Text -> EntityNameHS
EntityNameHS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ do
            FTTypeCon Maybe Text
_ Text
t <- Maybe FieldType
mfieldTy
            Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
t
        , do
            FTApp (FTTypeCon Maybe Text
_ Text
"Key") (FTTypeCon Maybe Text
_ Text
entName) <- Maybe FieldType
mfieldTy
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
entName
        , do
            FTApp (FTTypeCon Maybe Text
_ Text
"Maybe") (FTTypeCon Maybe Text
_ Text
t) <- Maybe FieldType
mfieldTy
            Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
t
        ]
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall k a. Ord k => k -> Map k a -> Bool
M.member EntityNameHS
entName Map EntityNameHS a
allEntities) -- check entity name exists in embed fmap
    forall (f :: * -> *) a. Applicative f => a -> f a
pure EntityNameHS
entName

type EntityMap = M.Map EntityNameHS UnboundEntityDef

constructEntityMap :: [UnboundEntityDef] -> EntityMap
constructEntityMap :: [UnboundEntityDef] -> EntityMap
constructEntityMap =
    forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\UnboundEntityDef
ent -> (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent), UnboundEntityDef
ent))

data FTTypeConDescr = FTKeyCon Text
    deriving Int -> FTTypeConDescr -> ShowS
[FTTypeConDescr] -> ShowS
FTTypeConDescr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FTTypeConDescr] -> ShowS
$cshowList :: [FTTypeConDescr] -> ShowS
show :: FTTypeConDescr -> String
$cshow :: FTTypeConDescr -> String
showsPrec :: Int -> FTTypeConDescr -> ShowS
$cshowsPrec :: Int -> FTTypeConDescr -> ShowS
Show

-- | Recurses through the 'FieldType'. Returns a 'Right' with the
-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of
-- a name and that name is present in the 'EmbedEntityMap' provided as
-- a first argument.
--
-- If the 'FieldType' represents a @Key something@, this returns a @'Left
-- ('Just' 'FTKeyCon')@.
--
-- If the 'FieldType' has a module qualified value, then it returns @'Left'
-- 'Nothing'@.
mEmbedded
    :: M.Map EntityNameHS a
    -> FieldType
    -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded :: forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
_ (FTTypeCon Just{} Text
_) =
    forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
ents (FTTypeCon Maybe Text
Nothing (Text -> EntityNameHS
EntityNameHS -> EntityNameHS
name)) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a. Maybe a
Nothing) (\a
_ -> forall a b. b -> Either a b
Right EntityNameHS
name) forall a b. (a -> b) -> a -> b
$ 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
_) =
    forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
ents (FTList FieldType
x) =
    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)) =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> FTTypeConDescr
FTKeyCon forall a b. (a -> b) -> a -> b
$ Text
a forall a. Semigroup a => a -> a -> a
<> Text
"Id"
mEmbedded Map EntityNameHS a
_ (FTApp FieldType
_ FieldType
_) =
    forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
_ (FTLit FieldTypeLit
_) =
    forall a b. a -> Either a b
Left 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 forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
allEntities (FieldDef -> FieldType
fieldType FieldDef
field) of
            Left Maybe FTTypeConDescr
_ -> forall a. a -> Maybe a -> a
fromMaybe ReferenceDef
NoReference forall a b. (a -> b) -> a -> b
$ do
                EntityNameHS
refEntName <- forall a. Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity Map EntityNameHS a
allEntities FieldDef
field
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ EntityNameHS -> ReferenceDef
ForeignRef EntityNameHS
refEntName
            Right EntityNameHS
em ->
                if EntityNameHS
em 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
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ Text -> String
unpack forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName forall a. Semigroup a => a -> a -> a
<> Text
": a self reference must be a Maybe or List"

setFieldReference :: ReferenceDef -> FieldDef -> FieldDef
setFieldReference :: ReferenceDef -> FieldDef -> FieldDef
setFieldReference ReferenceDef
ref FieldDef
field = FieldDef
field { fieldReference :: ReferenceDef
fieldReference = ReferenceDef
ref }

-- | Create data types and appropriate 'PersistEntity' instances for the given
-- 'UnboundEntityDef's.
--
-- This function should be used if you are only defining a single block of
-- Persistent models for the entire application. If you intend on defining
-- multiple blocks in different fiels, see 'mkPersistWith' which allows you
-- to provide existing entity definitions so foreign key references work.
--
-- Example:
--
-- @
-- mkPersist 'sqlSettings' ['persistLowerCase'|
--      User
--          name    Text
--          age     Int
--
--      Dog
--          name    Text
--          owner   UserId
--
-- |]
-- @
--
-- Example from a file:
--
-- @
-- mkPersist 'sqlSettings' $('persistFileWith' 'lowerCaseSettings' "models.persistentmodels")
-- @
--
-- For full information on the 'QuasiQuoter' syntax, see
-- "Database.Persist.Quasi" documentation.
mkPersist
    :: MkPersistSettings
    -> [UnboundEntityDef]
    -> Q [Dec]
mkPersist :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
mkPersist MkPersistSettings
mps = MkPersistSettings -> [EntityDef] -> [UnboundEntityDef] -> Q [Dec]
mkPersistWith MkPersistSettings
mps []

-- | Like 'mkPersist', but allows you to provide a @['EntityDef']@
-- representing the predefined entities. This function will include those
-- 'EntityDef' when looking for foreign key references.
--
-- You should use this if you intend on defining Persistent models in
-- multiple files.
--
-- Suppose we define a table @Foo@ which has no dependencies.
--
-- @
-- module DB.Foo where
--
--     'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'|
--         Foo
--            name    Text
--        |]
-- @
--
-- Then, we define a table @Bar@ which depends on @Foo@:
--
-- @
-- module DB.Bar where
--
--     import DB.Foo
--
--     'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'|
--         Bar
--             fooId  FooId
--      |]
-- @
--
-- Writing out the list of 'EntityDef' can be annoying. The
-- @$('discoverEntities')@ shortcut will work to reduce this boilerplate.
--
-- @
-- module DB.Quux where
--
--     import DB.Foo
--     import DB.Bar
--
--     'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'|
--         Quux
--             name     Text
--             fooId    FooId
--             barId    BarId
--      |]
-- @
--
-- @since 2.13.0.0
mkPersistWith
    :: MkPersistSettings
    -> [EntityDef]
    -> [UnboundEntityDef]
    -> Q [Dec]
mkPersistWith :: 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
            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)
            forall a b. (a -> b) -> a -> b
$ [UnboundEntityDef]
predefs
        entityMap :: EntityMap
entityMap =
            [UnboundEntityDef] -> EntityMap
constructEntityMap [UnboundEntityDef]
allEnts
        preexistingSet :: Set EntityNameHS
preexistingSet =
            forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> EntityNameHS
getEntityHaskellName [EntityDef]
preexistingEntities
        newEnts :: [UnboundEntityDef]
newEnts =
            forall a. (a -> Bool) -> [a] -> [a]
filter
                (\UnboundEntityDef
e -> UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
e forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set EntityNameHS
preexistingSet)
                [UnboundEntityDef]
allEnts
    [UnboundEntityDef]
ents <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM UnboundEntityDef -> Q Bool
shouldGenerateCode [UnboundEntityDef]
newEnts
    [[Extension]] -> Q ()
requireExtensions
        [ [Extension
TypeFamilies], [Extension
GADTs, Extension
ExistentialQuantification]
        , [Extension
DerivingStrategies], [Extension
GeneralizedNewtypeDeriving], [Extension
StandaloneDeriving]
        , [Extension
UndecidableInstances], [Extension
DataKinds], [Extension
FlexibleInstances]
        ]
    [Dec]
persistFieldDecs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
entityDecs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
Map EntityNameHS a
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkEntity EmbedEntityMap
embedEntityMap EntityMap
entityMap MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
jsonDecs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
uniqueKeyInstances <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
safeToInsertInstances <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkSafeToInsertInstance MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
symbolToFieldInstances <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkSymbolToFieldInstances MkPersistSettings
mps EntityMap
entityMap) [UnboundEntityDef]
ents
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ [Dec]
persistFieldDecs
        , [Dec]
entityDecs
        , [Dec]
jsonDecs
        , [Dec]
uniqueKeyInstances
        , [Dec]
symbolToFieldInstances
        , [Dec]
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 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
                            Q [Dec]
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 forall a. Maybe a
Nothing (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe Type
merr [Type]
withPersistStoreWriteCxt) (Name -> Type
ConT ''SafeToInsert Type -> Type -> Type
`AppT` Type
typ) []
    instanceOkay :: Q [Dec]
instanceOkay =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            [ Maybe Type -> Dec
mkInstance forall a. Maybe a
Nothing
            ]
    badInstance :: Q [Dec]
badInstance = do
        Type
err <- [t| TypeError (SafeToInsertErrorMessage $(pure typ)) |]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            [ Maybe Type -> Dec
mkInstance (forall a. a -> Maybe a
Just Type
err)
            ]

    withPersistStoreWriteCxt :: [Type]
withPersistStoreWriteCxt =
        if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
            then
                [Name -> Type
ConT ''PersistStoreWrite Type -> Type -> Type
`AppT` Type
backendT]
            else
                []


-- we can't just use 'isInstance' because TH throws an error
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode UnboundEntityDef
ed = do
    Maybe Name
mtyp <- String -> Q (Maybe Name)
lookupTypeName String
entityName
    case Maybe Name
mtyp of
        Maybe Name
Nothing -> do
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just Name
typeName -> do
            Bool
instanceExists <- Name -> [Type] -> Q Bool
isInstance ''PersistEntity [Name -> Type
ConT Name
typeName]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bool
not Bool
instanceExists)
  where
    entityName :: String
entityName =
        Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameHS -> Text
unEntityNameHS forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
getEntityHaskellName forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef forall a b. (a -> b) -> a -> b
$ UnboundEntityDef
ed

overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overEntityDef EntityDef -> EntityDef
f UnboundEntityDef
ued = UnboundEntityDef
ued { unboundEntityDef :: EntityDef
unboundEntityDef = EntityDef -> EntityDef
f (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ued) }

setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields MkPersistSettings
mps UnboundEntityDef
ued
    | UnboundEntityDef -> Bool
defaultIdType UnboundEntityDef
ued =
        (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overEntityDef
            (EntityIdDef -> EntityDef -> EntityDef
setEntityIdDef (ImplicitIdDef -> EntityIdDef -> EntityIdDef
setToMpsDefault (MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef MkPersistSettings
mps) (EntityDef -> EntityIdDef
getEntityId EntityDef
ed)))
            UnboundEntityDef
ued
    | Bool
otherwise =
        UnboundEntityDef
ued
  where
    ed :: EntityDef
ed =
        UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ued
    setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef
    setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef
setToMpsDefault ImplicitIdDef
iid (EntityIdField FieldDef
fd) =
        FieldDef -> EntityIdDef
EntityIdField FieldDef
fd
            { fieldType :: FieldType
fieldType =
                ImplicitIdDef -> EntityNameHS -> FieldType
iidFieldType ImplicitIdDef
iid (EntityDef -> EntityNameHS
getEntityHaskellName EntityDef
ed)
            , fieldSqlType :: SqlType
fieldSqlType =
                ImplicitIdDef -> SqlType
iidFieldSqlType ImplicitIdDef
iid
            , fieldAttrs :: [FieldAttr]
fieldAttrs =
                let
                    def :: [FieldAttr]
def =
                        forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Text -> FieldAttr
FieldAttrDefault forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Text
iidDefault ImplicitIdDef
iid)
                    maxlen :: [FieldAttr]
maxlen =
                        forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Integer -> FieldAttr
FieldAttrMaxlen forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplicitIdDef -> Maybe Integer
iidMaxLen ImplicitIdDef
iid)
                 in
                    [FieldAttr]
def forall a. Semigroup a => a -> a -> a
<> [FieldAttr]
maxlen forall a. Semigroup a => a -> a -> a
<> FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
            , fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn =
                Bool
True
            }
    setToMpsDefault ImplicitIdDef
_ EntityIdDef
x =
        EntityIdDef
x

-- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'.
-- For example, strip out any fields marked as MigrationOnly.
--
-- This should be called when performing Haskell codegen, but the 'EntityDef'
-- *should* keep all of the fields present when defining 'entityDef'. This is
-- necessary so that migrations know to keep these columns around, or to delete
-- them, as appropriate.
fixEntityDef :: UnboundEntityDef -> UnboundEntityDef
fixEntityDef :: UnboundEntityDef -> UnboundEntityDef
fixEntityDef UnboundEntityDef
ued =
    UnboundEntityDef
ued
        { unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
            forall a. (a -> Bool) -> [a] -> [a]
filter UnboundFieldDef -> Bool
isHaskellUnboundField (UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields UnboundEntityDef
ued)
        }

-- | Settings to be passed to the 'mkPersist' function.
data MkPersistSettings = MkPersistSettings
    { MkPersistSettings -> Type
mpsBackend :: Type
    -- ^ Which database backend we\'re using. This type is used for the
    -- 'PersistEntityBackend' associated type in the entities that are
    -- generated.
    --
    -- If the 'mpsGeneric' value is set to 'True', then this type is used for
    -- the non-Generic type alias. The data and type will be named:
    --
    -- @
    -- data ModelGeneric backend = Model { ... }
    -- @
    --
    -- And, for convenience's sake, we provide a type alias:
    --
    -- @
    -- type Model = ModelGeneric $(the type you give here)
    -- @
    , MkPersistSettings -> Bool
mpsGeneric :: Bool
    -- ^ Create generic types that can be used with multiple backends. Good for
    -- reusable code, but makes error messages harder to understand. Default:
    -- False.
    , MkPersistSettings -> Bool
mpsPrefixFields :: Bool
    -- ^ Prefix field names with the model name. Default: True.
    --
    -- Note: this field is deprecated. Use the mpsFieldLabelModifier  and
    -- 'mpsConstraintLabelModifier' instead.
    , MkPersistSettings -> Text -> Text -> Text
mpsFieldLabelModifier :: Text -> Text -> Text
    -- ^ Customise the field accessors and lens names using the entity and field
    -- name.  Both arguments are upper cased.
    --
    -- Default: appends entity and field.
    --
    -- Note: this setting is ignored if mpsPrefixFields is set to False.
    --
    -- @since 2.11.0.0
    , MkPersistSettings -> Text -> Text -> Text
mpsConstraintLabelModifier :: Text -> Text -> Text
    -- ^ Customise the Constraint names using the entity and field name. The
    -- result should be a valid haskell type (start with an upper cased letter).
    --
    -- Default: appends entity and field
    --
    -- Note: this setting is ignored if mpsPrefixFields is set to False.
    --
    -- @since 2.11.0.0
    , MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON :: Maybe EntityJSON
    -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's
    -- @Nothing@, no instances will be generated. Default:
    --
    -- @
    --  Just 'EntityJSON'
    --      { 'entityToJSON' = 'entityIdToJSON
    --      , 'entityFromJSON' = 'entityIdFromJSON
    --      }
    -- @
    , MkPersistSettings -> Bool
mpsGenerateLenses :: Bool
    -- ^ Instead of generating normal field accessors, generator lens-style
    -- accessors.
    --
    -- Default: False
    --
    -- @since 1.3.1
    , MkPersistSettings -> [Name]
mpsDeriveInstances :: [Name]
    -- ^ Automatically derive these typeclass instances for all record and key
    -- types.
    --
    -- Default: []
    --
    -- @since 2.8.1
    , MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef :: ImplicitIdDef
    -- ^ TODO: document
    --
    -- @since 2.13.0.0
    , MkPersistSettings -> Bool
mpsCamelCaseCompositeKeySelector :: Bool
    -- ^ Should we generate composite key accessors in the correct CamelCase style.
    --
    -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'False',
    -- then the field part of the accessor starts with the lowercase.
    -- This is a legacy style.
    --
    -- @
    -- data Key CompanyUser = CompanyUserKey
    --   { companyUserKeycompanyId :: CompanyId
    --   , companyUserKeyuserId :: UserId
    --   }
    -- @
    --
    -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'True',
    -- then field accessors are generated in CamelCase style.
    --
    -- @
    -- data Key CompanyUser = CompanyUserKey
    --   { companyUserKeyCompanyId :: CompanyId
    --   , companyUserKeyUserId :: UserId
    --   }
    -- @

    -- Default: False
    --
    -- @since 2.14.2.0
    }

{-# DEPRECATED mpsGeneric "The mpsGeneric function adds a considerable amount of overhead and complexity to the library without bringing significant benefit. We would like to remove it. If you require this feature, please comment on the linked GitHub issue, and we'll either keep it around, or we can figure out a nicer way to solve your problem.\n\n Github: https://github.com/yesodweb/persistent/issues/1204" #-}

-- |  Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default
-- value is 'autoIncrementingInteger'.
--
-- @since 2.13.0.0
setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings
setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings
setImplicitIdDef ImplicitIdDef
iid MkPersistSettings
mps =
    MkPersistSettings
mps { mpsImplicitIdDef :: ImplicitIdDef
mpsImplicitIdDef = ImplicitIdDef
iid }

getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType = do
    ImplicitIdDef
idDef <- MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef
    Bool
isGeneric <- MkPersistSettings -> Bool
mpsGeneric
    Type
backendTy <- MkPersistSettings -> Type
mpsBackend
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ImplicitIdDef -> Bool -> Type -> Type
iidType ImplicitIdDef
idDef Bool
isGeneric Type
backendTy

data EntityJSON = EntityJSON
    { EntityJSON -> Name
entityToJSON :: Name
    -- ^ Name of the @toJSON@ implementation for @Entity a@.
    , EntityJSON -> Name
entityFromJSON :: Name
    -- ^ Name of the @fromJSON@ implementation for @Entity a@.
    }

-- | Create an @MkPersistSettings@ with default values.
mkPersistSettings
    :: Type -- ^ Value for 'mpsBackend'
    -> 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 = forall m. Monoid m => m -> m -> m
(++)
    , mpsConstraintLabelModifier :: Text -> Text -> Text
mpsConstraintLabelModifier = forall m. Monoid m => m -> m -> m
(++)
    , mpsEntityJSON :: Maybe EntityJSON
mpsEntityJSON = 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
    }

-- | Use the 'SqlPersist' backend.
sqlSettings :: MkPersistSettings
sqlSettings :: MkPersistSettings
sqlSettings = Type -> MkPersistSettings
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) = forall a b. [Either a b] -> ([a], [b])
partitionEithers (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
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
stocks))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
ConT [Name]
stocks))
        anyclassDerives :: [DerivClause]
anyclassDerives = do
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
anyclasses))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (forall a. a -> Maybe a
Just DerivStrategy
AnyclassStrategy) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
ConT [Name]
anyclasses))
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DerivClause]
anyclassDerives) forall a b. (a -> b) -> a -> b
$ do
        [[Extension]] -> Q ()
requireExtensions [[Extension
DeriveAnyClass]]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
nameFinal [TyVarBndr ()]
paramsFinal
                forall a. Maybe a
Nothing
                [Con]
constrs
                ([DerivClause]
stockDerives forall a. Semigroup a => a -> a -> a
<> [DerivClause]
anyclassDerives)
  where
    stratFor :: Name -> Either Name Name
stratFor Name
n =
        if Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set Name
stockClasses then
            forall a b. a -> Either a b
Left Name
n
        else
            forall a b. b -> Either a b
Right Name
n

    stockClasses :: Set Name
stockClasses =
        forall a. Ord a => [a] -> Set a
Set.fromList (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"
        ] forall a. Semigroup a => a -> a -> a
<> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable
        ]
        )

    (Name
nameFinal, [TyVarBndr ()]
paramsFinal)
        | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
            ( UnboundEntityDef -> Name
mkEntityDefGenericName UnboundEntityDef
entDef
            , [ Name -> TyVarBndr ()
mkPlainTV Name
backendName
              ]
            )

        | Bool
otherwise =
            (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef, [])

    cols :: [VarBangType]
    cols :: [VarBangType]
cols = do
        UnboundFieldDef
fieldDef <- UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
        let
            recordNameE :: Name
recordNameE =
                MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef
            strictness :: Bang
strictness =
                if UnboundFieldDef -> Bool
unboundFieldStrict UnboundFieldDef
fieldDef
                then Bang
isStrict
                else Bang
notStrict
            fieldIdType :: Type
fieldIdType =
                MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef forall a. Maybe a
Nothing forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
recordNameE, Bang
strictness, Type
fieldIdType)

    constrs :: [Con]
constrs
        | UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundFieldDef -> Con
sumCon forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
        | Bool
otherwise = [Name -> [VarBangType] -> Con
RecC (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef) [VarBangType]
cols]

    sumCon :: UnboundFieldDef -> Con
sumCon UnboundFieldDef
fieldDef = Name -> [BangType] -> Con
NormalC
        (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef)
        [(Bang
notStrict, MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef forall a. Maybe a
Nothing 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)
        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
        forall a. Maybe a
Nothing
        (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) 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) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty BangType
types
  where
    types :: NonEmpty BangType
types =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UnboundFieldDef, IsNullable) -> BangType
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
lookup3 (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) NonEmpty ForeignFieldDef
fields

    force :: Bool
force = Text
"!force" 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 = 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 forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just IsNullable
y))

    lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
    lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
lookup3 Text
s [] =
        forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Text
"Column not found: " forall m. Monoid m => m -> m -> m
++ Text
s forall m. Monoid m => m -> m -> m
++ Text
" in unique " forall m. Monoid m => m -> m -> m
++ ConstraintNameHS -> Text
unConstraintNameHS ConstraintNameHS
constr
    lookup3 Text
x (UnboundFieldDef
fd:[UnboundFieldDef]
rest)
        | Text
x 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 =
      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. ***" ]

-- | This function renders a Template Haskell 'Type' for an 'UnboundFieldDef'.
-- It takes care to respect the 'mpsGeneric' setting to render an Id faithfully,
-- and it also ensures that the generated Haskell type is 'Maybe' if the
-- database column has that attribute.
--
-- For a database schema with @'mpsGeneric' = False@, this is simple - it uses
-- the @ModelNameId@ type directly. This resolves just fine.
--
-- If 'mpsGeneric' is @True@, then we have to do something a bit more
-- complicated. We can't refer to a @ModelNameId@ directly, because that @Id@
-- alias hides the backend type variable. Instead, we need to refer to:
--
-- > Key (ModelNameGeneric backend)
--
-- This means that the client code will need both the term @ModelNameId@ in
-- scope, as well as the @ModelNameGeneric@ constructor, despite the fact that
-- the @ModelNameId@ is the only term explicitly used (and imported).
--
-- However, we're not guaranteed to have @ModelName@ in scope - we've only
-- referenced @ModelNameId@ in code, and so code generation *should* work even
-- without this. Consider an explicit-style import:
--
-- @
-- import Model.Foo (FooId)
--
-- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase|
--   Bar
--     foo FooId
-- |]
-- @
--
-- This looks like it ought to work, but it would fail with @mpsGeneric@ being
-- enabled. One hacky work-around is to perform a @'lookupTypeName' :: String ->
-- Q (Maybe Name)@ on the @"ModelNameId"@ type string. If the @Id@ is
-- a reference in the 'EntityMap' and @lookupTypeName@ returns @'Just' name@,
-- then that 'Name' contains the fully qualified information needed to use the
-- 'Name' without importing it at the client-site. Then we can perform a bit of
-- surgery on the 'Name' to strip the @Id@ suffix, turn it into a 'Type', and
-- apply the 'Key' constructor.
maybeIdType
    :: MkPersistSettings
    -> EntityMap
    -> UnboundFieldDef
    -> Maybe Name -- ^ backend
    -> Maybe IsNullable
    -> Type
maybeIdType :: 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 =
        forall a. a -> Maybe a -> a
fromMaybe (FieldType -> Type
ftToType forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
fieldDef) forall a b. (a -> b) -> a -> b
$ do
            EntityNameHS
typ <- EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
fieldDef
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                Name -> Type
ConT ''Key
                Type -> Type -> Type
`AppT` MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
typ (Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Name
backendName Maybe Name
mbackend)

    -- TODO: if we keep mpsGeneric, this needs to check 'mpsGeneric' and then
    -- append Generic to the model name, probably
    _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 forall a b. (a -> b) -> a -> b
$ OccName -> NameFlavour -> Name
Name (String -> OccName
OccName (Text -> String
T.unpack Text
name)) NameFlavour
nameFlavor

    -- | TODO: if we keep mpsGeneric, let's incorporate this behavior here, so
    -- end users don't need to import the constructor type as well as the id type
    --
    -- Returns 'Nothing' if the given text does not appear to be a table reference.
    -- In that case, do the usual thing for generating a type name.
    --
    -- Returns a @Just typ@ if the text appears to be a model name, and if the
    -- @ModelId@ type is in scope. The 'Type' is a fully qualified reference to
    -- @'Key' ModelName@ such that end users won't have to import it directly.
    _lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type)
    _lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type)
_lookupReferencedTable EntityMap
em Text
fieldTypeText = do
        let
            mmodelIdString :: Maybe String
mmodelIdString = do
                Text
fieldTypeNoId <- Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
fieldTypeText
                UnboundEntityDef
_ <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> EntityNameHS
EntityNameHS Text
fieldTypeNoId) EntityMap
em
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
fieldTypeText)
        case Maybe String
mmodelIdString of
            Maybe String
Nothing ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just String
modelIdString -> do
                Maybe Name
mIdName <- String -> Q (Maybe Name)
lookupTypeName String
modelIdString
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
_removeIdFromTypeSuffix Maybe Name
mIdName

    _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String
    _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String
_fieldNameEndsWithId UnboundFieldDef
ufd = FieldType -> Maybe String
go (UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
ufd)
      where
        go :: FieldType -> Maybe String
go = \case
            FTTypeCon Maybe Text
mmodule Text
name -> do
                Text
a <- Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
name
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                    Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                        [ case Maybe Text
mmodule of
                            Maybe Text
Nothing ->
                                Text
""
                            Just Text
m ->
                                forall a. Monoid a => [a] -> a
mconcat [Text
m, Text
"."]
                        ,  Text
a
                        , Text
"Id"
                        ]
            FieldType
_ ->
                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

-- | TODO:
--
-- if we keep mpsGeneric
-- then
--      let's make this fully qualify the generic name
-- else
--      let's delete it
genericDataType
    :: MkPersistSettings
    -> EntityNameHS
    -> Type -- ^ backend
    -> Type
genericDataType :: 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 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

-- needs:
--
-- * isEntitySum ed
--     * field accesor
-- * getEntityFields ed
--     * used in goSum, or sumConstrName
-- * mkEntityDefName ed
--     * uses entityHaskell
-- * sumConstrName ed fieldDef
--     * only needs entity name and field name
--
-- data MkToPersistFields = MkToPersistFields
--     { isEntitySum :: Bool
--     , entityHaskell :: HaskellNameHS
--     , entityFieldNames :: [FieldNameHS]
--     }
mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkToPersistFields MkPersistSettings
mps UnboundEntityDef
ed = do
    let isSum :: Bool
isSum = UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
ed
        fields :: [UnboundFieldDef]
fields = UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ed
    [Clause]
clauses <-
        if Bool
isSum
            then forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith UnboundFieldDef -> Int -> Q Clause
goSum [UnboundFieldDef]
fields [Int
1..]
            else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => a -> m a
return Q Clause
go
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'toPersistFields [Clause]
clauses
  where
    go :: Q Clause
    go :: Q Clause
go = do
        [Name]
xs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
fieldCount forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        let name :: Name
name = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ed
            pat :: Pat
pat = Name -> [Pat] -> Pat
conp Name
name 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
sp <- [|toPersistValue|]
        let bod :: Exp
bod = [Exp] -> Exp
ListE 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] Exp
bod

    fieldCount :: Int
fieldCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ed)

    goSum :: UnboundFieldDef -> Int -> Q Clause
    goSum :: UnboundFieldDef -> Int -> Q Clause
goSum UnboundFieldDef
fieldDef Int
idx = do
        let name :: Name
name = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
ed UnboundFieldDef
fieldDef
        Exp
enull <- [|PersistNull|]
        let beforeCount :: Int
beforeCount = Int
idx forall a. Num a => a -> a -> a
- Int
1
            afterCount :: Int
afterCount = Int
fieldCount forall a. Num a => a -> a -> a
- Int
idx
            before :: [Exp]
before = forall a. Int -> a -> [a]
replicate Int
beforeCount Exp
enull
            after :: [Exp]
after = forall a. Int -> a -> [a]
replicate Int
afterCount Exp
enull
        Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        Exp
sp <- [|toPersistValue|]
        let body :: Exp
body = [Exp] -> Exp
ListE forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                [ [Exp]
before
                , [Exp
sp Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x]
                , [Exp]
after
                ]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Name -> [Pat] -> Pat
conp Name
name [Name -> Pat
VarP Name
x]] Exp
body

mkToFieldNames :: [UniqueDef] -> Q Dec
mkToFieldNames :: [UniqueDef] -> Q Dec
mkToFieldNames [UniqueDef]
pairs = do
    [Clause]
pairs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Quote m => UniqueDef -> m Clause
go [UniqueDef]
pairs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueToFieldNames forall a b. (a -> b) -> a -> b
$ [Clause] -> [Clause]
degen [Clause]
pairs'
  where
    go :: UniqueDef -> m Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
names [Text]
_) = do
        Exp
names' <- forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift NonEmpty ForeignFieldDef
names
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            [Pat] -> Exp -> Clause
normalClause
                [Name -> [(Name, Pat)] -> Pat
RecP (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
constr) []]
                Exp
names'

mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues [UniqueDef]
pairs = do
    [Clause]
pairs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UniqueDef -> Q Clause
go [UniqueDef]
pairs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueToValues forall a b. (a -> b) -> a -> b
$ [Clause] -> [Clause]
degen [Clause]
pairs'
  where
    go :: UniqueDef -> Q Clause
    go :: UniqueDef -> Q Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
names [Text]
_) = do
        NonEmpty Name
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"x") NonEmpty ForeignFieldDef
names
        let pat :: Pat
pat = Name -> [Pat] -> Pat
conp (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
constr) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
        Exp
tpv <- [|toPersistValue|]
        let bod :: Exp
bod = [Exp] -> Exp
ListE 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] Exp
bod

isNotNull :: PersistValue -> Bool
isNotNull :: PersistValue -> Bool
isNotNull PersistValue
PersistNull = Bool
False
isNotNull PersistValue
_ = Bool
True

mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft :: forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft a -> c
_ (Right b
r) = forall a b. b -> Either a b
Right b
r
mapLeft a -> c
f (Left a
l)  = forall a b. a -> Either a b
Left (a -> c
f a
l)

-- needs:
--
-- * getEntityFields
--     * sumConstrName on field
-- * fromValues
-- * entityHaskell
-- * sumConstrName
-- * entityDefConE
--
--
mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues MkPersistSettings
mps UnboundEntityDef
entDef
    | UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef = do
        Exp
nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
        [Clause]
clauses <- [UnboundFieldDef] -> [UnboundFieldDef] -> Q [Clause]
mkClauses [] forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Clause]
clauses forall m. Monoid m => m -> m -> m
`mappend` [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
nothing]
    | Bool
otherwise =
        UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues UnboundEntityDef
entDef Text
"fromPersistValues" Exp
entE
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundFieldDef -> FieldNameHS
unboundFieldNameHS
        forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter UnboundFieldDef -> Bool
isHaskellUnboundField
        forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
  where
    entName :: Text
entName = EntityNameHS -> Text
unEntityNameHS forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef
    mkClauses :: [UnboundFieldDef] -> [UnboundFieldDef] -> Q [Clause]
mkClauses [UnboundFieldDef]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    mkClauses [UnboundFieldDef]
before (UnboundFieldDef
field:[UnboundFieldDef]
after) = do
        Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        let null' :: Pat
null' = Name -> [Pat] -> Pat
conp 'PersistNull []
            pat :: Pat
pat = [Pat] -> Pat
ListP forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const Pat
null') [UnboundFieldDef]
before
                , [Name -> Pat
VarP Name
x]
                , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const Pat
null') [UnboundFieldDef]
after
                ]
            constr :: Exp
constr = Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
field
        Exp
fs <- [|fromPersistValue $(return $ VarE x)|]
        let guard' :: Guard
guard' = Exp -> Guard
NormalG forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'isNotNull Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x
        let clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] ([(Guard, Exp)] -> Body
GuardedB [(Guard
guard', Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
constr) Exp
fmapE (forall a. a -> Maybe a
Just Exp
fs))]) []
        [Clause]
clauses <- [UnboundFieldDef] -> [UnboundFieldDef] -> Q [Clause]
mkClauses (UnboundFieldDef
field forall a. a -> [a] -> [a]
: [UnboundFieldDef]
before) [UnboundFieldDef]
after
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Clause
clause forall a. a -> [a] -> [a]
: [Clause]
clauses
    entE :: Exp
entE = UnboundEntityDef -> Exp
entityDefConE UnboundEntityDef
entDef


type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lensPTH :: 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s -> b -> t
sbt s
s) (a -> f b
afb 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 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 -- ^ constructor name
    -> [Name] -- ^ list of field names
    -> Exp -- ^ record value
    -> Name -- ^ field name to update
    -> Exp -- ^ new value
    -> Q Exp
fieldUpd :: Name -> [Name] -> Exp -> Name -> Exp -> Q Exp
fieldUpd Name
con [Name]
names Exp
record Name
name Exp
new = do
    [(Name, Pat)]
pats <-
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names forall a b. (a -> b) -> a -> b
$ \Name
k -> do
            Pat
varName <- Name -> Pat
VarP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
k)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Name
k, Pat
varName) | Name
k forall a. Eq a => a -> a -> Bool
/= Name
name]

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
record
        [ Pat -> Body -> [Dec] -> Match
Match (Name -> [(Name, Pat)] -> Pat
RecP Name
con [(Name, Pat)]
pats) (Exp -> Body
NormalB Exp
body) []]
    where
        body :: Exp
body = Name -> [FieldExp] -> Exp
RecConE Name
con
            [ if Name
k 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
    Exp
lens' <- [|lensPTH|]
    Exp
getId <- [|entityKey|]
    Exp
setId <- [|\(Entity _ value) key -> Entity key value|]
    Exp
getVal <- [|entityVal|]
    Exp
dot <- [|(.)|]
    Name
keyVar <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"key"
    Name
valName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
    Name
xName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    let idClause :: Clause
idClause = [Pat] -> Exp -> Clause
normalClause
            [Name -> [Pat] -> Pat
conp (UnboundEntityDef -> Name
keyIdName UnboundEntityDef
entDef) []]
            (Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getId Exp -> Exp -> Exp
`AppE` Exp
setId)
    (Clause
idClause forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Name -> Name -> Name -> UnboundFieldDef -> Clause
toSumClause Exp
lens' Name
keyVar Name
valName Name
xName) (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef)
        else forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Exp
-> Exp
-> Exp
-> Name
-> Name
-> Name
-> UnboundFieldDef
-> Name
-> Q Clause
toClause Exp
lens' Exp
getVal Exp
dot Name
keyVar Name
valName Name
xName) (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef) [Name]
fieldNames
  where
    fieldNames :: [Name]
fieldNames = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
entDef 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
        Exp
setter <- Q Exp
mkSetter
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
            [Name -> [Pat] -> Pat
conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) []]
            (Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getter Exp -> Exp -> Exp
`AppE` Exp
setter)
      where
        defName :: Name
defName = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef
        getter :: Exp
getter = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Name -> Exp
fieldSel Name
defName Name
fieldName) Exp
dot (forall a. a -> Maybe a
Just Exp
getVal)
        mkSetter :: Q Exp
mkSetter = do
            Exp
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)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE
                [ Name -> [Pat] -> Pat
conp 'Entity [Name -> Pat
VarP Name
keyVar, Name -> Pat
VarP Name
valName]
                , Name -> Pat
VarP Name
xName
                ]
                forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Entity Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
keyVar Exp -> Exp -> Exp
`AppE` Exp
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 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]
            ] forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
valName)
            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 forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
xName) []

            -- FIXME It would be nice if the types expressed that the Field is
            -- a sum type and therefore could result in Maybe.
            forall a. a -> [a] -> [a]
: if forall (t :: * -> *) a. Foldable t => t a -> Int
length (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef) 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
            ]
            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)

-- | declare the key type and associated instances
-- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field
mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec MkPersistSettings
mps UnboundEntityDef
entDef = do
    ([Dec]
instDecs, [Name]
i) <-
      if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
        then if Bool -> Bool
not Bool
useNewtype
               then do [Dec]
pfDec <- Q [Dec]
pfInstD
                       forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
pfDec, [Name] -> [Name]
supplement [''Generic])
               else do [Dec]
gi <- Q [Dec]
genericNewtypeInstances
                       forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
gi, [Name] -> [Name]
supplement [])
        else if Bool -> Bool
not Bool
useNewtype
               then do [Dec]
pfDec <- Q [Dec]
pfInstD
                       forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
pfDec, [Name] -> [Name]
supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])
                else do
                    let allInstances :: [Name]
allInstances = [Name] -> [Name]
supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
                    if Bool
customKeyType
                      then forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Name]
allInstances)
                      else do
                        [Dec]
bi <- Q [Dec]
backendKeyI
                        forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
bi, [Name]
allInstances)

    Q ()
requirePersistentExtensions

    -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1"
    -- This is much better for debugging/logging purposes
    -- cf. https://github.com/yesodweb/persistent/issues/1104
    let alwaysStockStrategyTypeclasses :: [Name]
alwaysStockStrategyTypeclasses = [''Show, ''Read]
        deriveClauses :: [DerivClause]
deriveClauses = 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
alwaysStockStrategyTypeclasses)
                then Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) [(Name -> Type
ConT Name
typeclass)]
                else Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (forall a. a -> Maybe a
Just DerivStrategy
NewtypeStrategy) [(Name -> Type
ConT Name
typeclass)]
            ) [Name]
i

#if MIN_VERSION_template_haskell(2,15,0)
    let kd :: Dec
kd = if Bool
useNewtype
               then [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [] forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
k) Type
recordType) forall a. Maybe a
Nothing Con
dec [DerivClause]
deriveClauses
               else [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD    [] forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
k) Type
recordType) 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
kd, [Dec]
instDecs)
  where
    keyConE :: Exp
keyConE = UnboundEntityDef -> Exp
keyConExp UnboundEntityDef
entDef
    unKeyE :: Exp
unKeyE = UnboundEntityDef -> Exp
unKeyExp UnboundEntityDef
entDef
    dec :: Con
dec = Name -> [VarBangType] -> Con
RecC (UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList 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 = -- FIXME: generate a PersistMap instead of PersistList
      [d|instance PersistField (Key $(pure recordType)) where
            toPersistValue = PersistList . keyToValues
            fromPersistValue (PersistList l) = keyFromValues l
            fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got
         instance PersistFieldSql (Key $(pure recordType)) where
            sqlType _ = SqlString
         instance ToJSON (Key $(pure recordType))
         instance FromJSON (Key $(pure recordType))
      |]

    backendKeyGenericI :: Q [Dec]
backendKeyGenericI =
        [d| instance PersistStore $(pure backendT) =>
              ToBackendKey $(pure backendT) $(pure recordType) where
                toBackendKey   = $(return unKeyE)
                fromBackendKey = $(return keyConE)
        |]
    backendKeyI :: Q [Dec]
backendKeyI = let bdt :: Type
bdt = MkPersistSettings -> Type
backendDataType MkPersistSettings
mps in
        [d| instance ToBackendKey $(pure bdt) $(pure recordType) where
                toBackendKey   = $(return unKeyE)
                fromBackendKey = $(return keyConE)
        |]

    genericNewtypeInstances :: Q [Dec]
genericNewtypeInstances = do
        Q ()
requirePersistentExtensions

        [Dec]
alwaysInstances <-
          -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here
          [d|deriving stock instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType))
             deriving stock instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType))
             deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType))
             deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType))
             deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType))
             deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType))
             deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType))
             deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType))
             deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType))
             deriving newtype instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType))
             deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType))
              |]

        forall m. Monoid m => m -> m -> m
mappend [Dec]
alwaysInstances forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            if Bool
customKeyType
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            else Q [Dec]
backendKeyGenericI

    useNewtype :: Bool
useNewtype = MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype MkPersistSettings
mps UnboundEntityDef
entDef
    customKeyType :: Bool
customKeyType =
        forall (t :: * -> *). Foldable t => t Bool -> Bool
or
            [ Bool -> Bool
not (UnboundEntityDef -> Bool
defaultIdType UnboundEntityDef
entDef)
            , Bool -> Bool
not Bool
useNewtype
            , 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 forall a. Eq a => a -> a -> Bool
== ''BackendKey ->
                    Bool
True
            Type
_ ->
                Bool
False

    supplement :: [Name] -> [Name]
    supplement :: [Name] -> [Name]
supplement [Name]
names = [Name]
names forall a. Semigroup a => a -> a -> a
<> (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
names) forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> [Name]
mpsDeriveInstances MkPersistSettings
mps)

-- | Returns 'True' if the key definition has less than 2 fields.
--
-- @since 2.11.0.0
pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype MkPersistSettings
mps UnboundEntityDef
entDef = forall (t :: * -> *) a. Foldable t => t a -> Int
length (MkPersistSettings -> UnboundEntityDef -> NonEmpty VarBangType
keyFields MkPersistSettings
mps UnboundEntityDef
entDef) forall a. Ord a => a -> a -> Bool
< Int
2

-- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the
-- QuasiQuoter produces for an implicit ID and
defaultIdType :: UnboundEntityDef -> Bool
defaultIdType :: 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 ->
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldNameHS -> VarBangType
naturalKeyVar (UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
        DefaultKey FieldNameDB
_ ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> Type
getImplicitIdType MkPersistSettings
mps
        SurrogateKey UnboundIdDef
k ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar 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 ->
                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 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 =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((FieldNameHS
fieldName forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS)

mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyToValues MkPersistSettings
mps UnboundEntityDef
entDef = do
    Name
recordN <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"record"
    Name -> [Clause] -> Dec
FunD 'keyToValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
            NaturalKey UnboundCompositeDef
ucd -> do
                [Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
recordN] 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 [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|]
  where
    toValuesPrimary :: Name -> UnboundCompositeDef -> Q Exp
toValuesPrimary Name
recName UnboundCompositeDef
ucd =
        [Exp] -> Exp
ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> FieldNameHS -> Q Exp
f Name
recName) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
    f :: Name -> FieldNameHS -> Q Exp
f Name
recName FieldNameHS
fieldNameHS =
        [|
        toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE 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) []

-- needs:
--
-- * entityPrimary
-- * keyConExp entDef
mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues MkPersistSettings
_mps UnboundEntityDef
entDef =
    Name -> [Clause] -> Dec
FunD 'keyFromValues 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 (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
            PrimarySpec
_ -> do
                Exp
e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
                forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Exp -> Clause
normalClause [] Exp
e]
  where
    keyConE :: Exp
keyConE = UnboundEntityDef -> Exp
keyConExp UnboundEntityDef
entDef

headNote :: [PersistValue] -> PersistValue
headNote :: [PersistValue] -> PersistValue
headNote = \case
  [PersistValue
x] -> PersistValue
x
  [PersistValue]
xs -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mkKeyFromValues: expected a list of one element, got: " forall m. Monoid m => m -> m -> m
`mappend` forall a. Show a => a -> String
show [PersistValue]
xs

-- needs from entity:
--
-- * entityText entDef
--     * entityHaskell
-- * entityDB entDef
--
-- needs from fields:
--
-- * mkPersistValue
--     *  fieldHaskell
--
-- data MkFromValues = MkFromValues
--     { entityHaskell :: EntityNameHS
--     , entityDB :: EntitynameDB
--     , entityFieldNames :: [FieldNameHS]
--     }
fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues UnboundEntityDef
entDef Text
funName Exp
constructExpr [FieldNameHS]
fields = do
    Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    let
        funMsg :: Text
funMsg =
            forall a. Monoid a => [a] -> a
mconcat
                [ UnboundEntityDef -> Text
entityText UnboundEntityDef
entDef
                , Text
": "
                , Text
funName
                , Text
" failed on: "
                ]
    Exp
patternMatchFailure <-
        [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
    Clause
suc <- Q Clause
patternSuccess
    forall (m :: * -> *) a. Monad m => a -> m a
return [ Clause
suc, [Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
x] Exp
patternMatchFailure ]
  where
    tableName :: Text
tableName =
        EntityNameDB -> Text
unEntityNameDB (EntityDef -> EntityNameDB
entityDB (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef))
    patternSuccess :: Q Clause
patternSuccess =
        case [FieldNameHS]
fields of
            [] -> do
                Exp
rightE <- [|Right|]
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [[Pat] -> Pat
ListP []] (Exp
rightE Exp -> Exp -> Exp
`AppE` Exp
constructExpr)
            [FieldNameHS]
_ -> do
                Name
x1 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x1"
                [Name]
restNames <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
i -> forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ String
"x" forall m. Monoid m => m -> m -> m
`mappend` forall a. Show a => a -> String
show Int
i) [Int
2..forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldNameHS]
fields]
                (Exp
fpv1:[Exp]
mkPersistValues) <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldNameHS -> Q Exp
mkPersistValue [FieldNameHS]
fields
                Exp
app1E <- [|(<$>)|]
                let conApp :: Exp
conApp = Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
app1E Exp
fpv1 Exp
constructExpr Name
x1
                Exp
applyE <- [|(<*>)|]
                let applyFromPersistValue :: Exp -> Exp -> Name -> Exp
applyFromPersistValue = Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
applyE

                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
                    [[Pat] -> Pat
ListP forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP (Name
x1forall a. a -> [a] -> [a]
:[Name]
restNames)]
                    (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
exp (Name
name, Exp
fpv) -> Exp -> Exp -> Name -> Exp
applyFromPersistValue Exp
fpv Exp
exp Name
name) Exp
conApp (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
restNames [Exp]
mkPersistValues))

    infixFromPersistValue :: Exp -> Exp -> Exp -> Name -> Exp
infixFromPersistValue Exp
applyE Exp
fpv Exp
exp Name
name =
        Exp -> Exp -> Exp -> Exp
UInfixE Exp
exp Exp
applyE (Exp
fpv Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
name)

    mkPersistValue :: FieldNameHS -> Q Exp
mkPersistValue FieldNameHS
field =
        let fieldName :: Text
fieldName = FieldNameHS -> Text
unFieldNameHS FieldNameHS
field
        in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|]

-- |  Render an error message based on the @tableName@ and @fieldName@ with
-- the provided message.
--
-- @since 2.8.2
fieldError :: Text -> Text -> Text -> Text
fieldError :: Text -> Text -> Text -> Text
fieldError Text
tableName Text
fieldName Text
err = 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EntityDef -> Bool
isEntitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
preDef)) forall a b. (a -> b) -> a -> b
$ do
        String -> Q ()
reportWarning 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"
            ]

    Exp
entityDefExp <- forall a.
MkPersistSettings
-> Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp
liftAndFixKeys MkPersistSettings
mps Map EntityNameHS a
embedEntityMap EntityMap
entityMap UnboundEntityDef
preDef
    let
        entDef :: UnboundEntityDef
entDef =
            UnboundEntityDef -> UnboundEntityDef
fixEntityDef UnboundEntityDef
preDef
    EntityFieldsTH
fields <- MkPersistSettings
-> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
mkFields MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
    let name :: Name
name = UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef
    let clazz :: Type
clazz = Name -> Type
ConT ''PersistEntity Type -> Type -> Type
`AppT` Type
genDataType
    Dec
tpf <- MkPersistSettings -> UnboundEntityDef -> Q Dec
mkToPersistFields MkPersistSettings
mps UnboundEntityDef
entDef
    [Clause]
fpv <- MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues MkPersistSettings
mps UnboundEntityDef
entDef
    Dec
utv <- [UniqueDef] -> Q Dec
mkUniqueToValues forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef
    Dec
puk <- UnboundEntityDef -> Q Dec
mkUniqueKeys UnboundEntityDef
entDef
    [[Dec]]
fkc <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings
-> UnboundEntityDef -> UnboundForeignDef -> Q [Dec]
mkForeignKeysComposite MkPersistSettings
mps UnboundEntityDef
entDef) forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundForeignDef]
unboundForeignDefs UnboundEntityDef
entDef

    Dec
toFieldNames <- [UniqueDef] -> Q Dec
mkToFieldNames forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef

    (Dec
keyTypeDec, [Dec]
keyInstanceDecs) <- MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec MkPersistSettings
mps UnboundEntityDef
entDef
    Dec
keyToValues' <- MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyToValues MkPersistSettings
mps UnboundEntityDef
entDef
    Dec
keyFromValues' <- MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues MkPersistSettings
mps UnboundEntityDef
entDef

    let addSyn :: [Dec] -> [Dec]
addSyn -- FIXME maybe remove this
            | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps = (:) forall a b. (a -> b) -> a -> b
$
                Name -> [TyVarBndr ()] -> Type -> Dec
TySynD Name
name [] forall a b. (a -> b) -> a -> b
$
                    MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
entName forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> Type
mpsBackend MkPersistSettings
mps
            | Bool
otherwise = forall a. a -> a
id

    [Clause]
lensClauses <- MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
mkLensClauses MkPersistSettings
mps UnboundEntityDef
entDef Type
genDataType

    [Dec]
lenses <- MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkLenses MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
    let instanceConstraint :: [Type]
instanceConstraint = if Bool -> Bool
not (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) then [] else
          [Name -> [Type] -> Type
mkClassP ''PersistStore [Type
backendT]]

    [Dec
keyFromRecordM'] <-
        case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
            NaturalKey UnboundCompositeDef
ucd -> do
                let keyFields' :: NonEmpty Name
keyFields' = MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd
                NonEmpty (Name, Name)
keyFieldNames' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty Name
keyFields' forall a b. (a -> b) -> a -> b
$ \Name
fieldName -> do
                                         Name
fieldVarName <- forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
fieldName)
                                         forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fieldName, Name
fieldVarName)

                let keyCon :: Name
keyCon = UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef
                    constr :: Exp
constr =
                        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                            Exp -> Exp -> Exp
AppE
                            (Name -> Exp
ConE Name
keyCon)
                            (Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name, Name)
keyFieldNames')
                    keyFromRec :: Q Pat
keyFromRec = forall (m :: * -> *). Quote m => Name -> m Pat
varP 'keyFromRecordM
                    fieldPat :: [(Name, Pat)]
fieldPat = [(Name
fieldName, Name -> Pat
VarP Name
fieldVarName) | (Name
fieldName, Name
fieldVarName) <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Name, Name)
keyFieldNames']
                    lam :: Exp
lam = [Pat] -> Exp -> Exp
LamE [Name -> [(Name, Pat)] -> Pat
RecP Name
name [(Name, Pat)]
fieldPat ] Exp
constr
                [d|
                    $(keyFromRec) = Just $(pure lam)
                    |]

            PrimarySpec
_ ->
                [d|$(varP 'keyFromRecordM) = Nothing|]

    Dec
dtd <- MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec
dataTypeDec MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
    let
        allEntDefs :: [Con]
allEntDefs =
            EntityFieldTH -> Con
entityFieldTHCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityFieldsTH -> [EntityFieldTH]
efthAllFields EntityFieldsTH
fields
        allEntDefClauses :: [Clause]
allEntDefClauses =
            EntityFieldTH -> Clause
entityFieldTHClause forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityFieldsTH -> [EntityFieldTH]
efthAllFields EntityFieldsTH
fields

    Dec
mkTabulateA <- do
        Name
fromFieldName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"fromField"
        let names'types :: [(Name, Type)]
names'types =
                forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name
n, Type
_) -> Name
n forall a. Eq a => a -> a -> Bool
/= String -> Name
mkName String
"Id") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Con -> (Name, Type)
getConNameAndType forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityFieldTH -> Con
entityFieldTHCon) forall a b. (a -> b) -> a -> b
$ EntityFieldsTH -> [EntityFieldTH]
entityFieldsTHFields EntityFieldsTH
fields
            getConNameAndType :: Con -> (Name, Type)
getConNameAndType = \case
                ForallC [] [Type
EqualityT `AppT` Type
_ `AppT` Type
fieldTy] (NormalC Name
conName []) ->
                    (Name
conName, Type
fieldTy)
                Con
other ->
                    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ 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
"    " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
other
                        ]
            mkEntityVal :: Exp
mkEntityVal =
                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
                            (forall a. a -> Maybe a
Just Exp
acc)
                            (Name -> Exp
VarE '(<*>))
                            (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
primaryKeyField =
                forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Con -> (Name, Type)
getConNameAndType forall a b. (a -> b) -> a -> b
$ EntityFieldTH -> Con
entityFieldTHCon forall a b. (a -> b) -> a -> b
$ EntityFieldsTH -> EntityFieldTH
entityFieldsTHPrimary EntityFieldsTH
fields
        Exp
body <-
            if EntityDef -> Bool
isEntitySum forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef
            then [| error "tabulateEntityA does not make sense for sum type" |]
            else
                [|
                    Entity
                        <$> $(varE fromFieldName) $(conE primaryKeyField)
                        <*> $(pure mkEntityVal)
                |]


        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Name -> [Clause] -> Dec
FunD 'tabulateEntityA
            [ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
fromFieldName] (Exp -> Body
NormalB Exp
body) []
            ]

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec] -> [Dec]
addSyn forall a b. (a -> b) -> a -> b
$
       Dec
dtd forall a. a -> [a] -> [a]
: forall a. Monoid a => [a] -> a
mconcat [[Dec]]
fkc forall m. Monoid m => m -> m -> m
`mappend`
      ( [ Name -> [TyVarBndr ()] -> Type -> Dec
TySynD (UnboundEntityDef -> Name
keyIdName UnboundEntityDef
entDef) [] forall a b. (a -> b) -> a -> b
$
            Name -> Type
ConT ''Key Type -> Type -> Type
`AppT` Name -> Type
ConT Name
name
      , [Type] -> Type -> [Dec] -> Dec
instanceD [Type]
instanceConstraint Type
clazz
        [ MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
uniqueTypeDec MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef
        , Dec
keyTypeDec
        , Dec
keyToValues'
        , Dec
keyFromValues'
        , Dec
keyFromRecordM'
        , Dec
mkTabulateA
        , Name -> [Clause] -> Dec
FunD 'entityDef [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
entityDefExp]
        , Dec
tpf
        , Name -> [Clause] -> Dec
FunD 'fromPersistValues [Clause]
fpv
        , Dec
toFieldNames
        , Dec
utv
        , Dec
puk
#if MIN_VERSION_template_haskell(2,15,0)
        , [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD
            []
            forall a. Maybe a
Nothing
            (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''EntityField) Type
genDataType) (Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ"))
            forall a. Maybe a
Nothing
            [Con]
allEntDefs
            []
#else
        , DataInstD
            []
            ''EntityField
            [ genDataType
            , VarT $ mkName "typ"
            ]
            Nothing
            allEntDefs
            []
#endif
        , Name -> [Clause] -> Dec
FunD 'persistFieldDef [Clause]
allEntDefClauses
#if MIN_VERSION_template_haskell(2,15,0)
        , TySynEqn -> Dec
TySynInstD
            (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn
               forall a. Maybe a
Nothing
               (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistEntityBackend) Type
genDataType)
               (MkPersistSettings -> Type
backendDataType MkPersistSettings
mps))
#else
        , TySynInstD
            ''PersistEntityBackend
            (TySynEqn
               [genDataType]
               (backendDataType mps))
#endif
        , Name -> [Clause] -> Dec
FunD 'persistIdField [[Pat] -> Exp -> Clause
normalClause [] (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> Name
keyIdName UnboundEntityDef
entDef)]
        , Name -> [Clause] -> Dec
FunD 'fieldLens [Clause]
lensClauses
        ]
      ] forall m. Monoid m => m -> m -> m
`mappend` [Dec]
lenses) forall m. Monoid m => m -> m -> m
`mappend` [Dec]
keyInstanceDecs
  where
    genDataType :: Type
genDataType =
        MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
entName Type
backendT
    entName :: EntityNameHS
entName =
        UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
preDef

data EntityFieldsTH = EntityFieldsTH
    { EntityFieldsTH -> EntityFieldTH
entityFieldsTHPrimary :: EntityFieldTH
    , EntityFieldsTH -> [EntityFieldTH]
entityFieldsTHFields :: [EntityFieldTH]
    }

efthAllFields :: EntityFieldsTH -> [EntityFieldTH]
efthAllFields :: EntityFieldsTH -> [EntityFieldTH]
efthAllFields EntityFieldsTH{[EntityFieldTH]
EntityFieldTH
entityFieldsTHFields :: [EntityFieldTH]
entityFieldsTHPrimary :: EntityFieldTH
entityFieldsTHPrimary :: EntityFieldsTH -> EntityFieldTH
entityFieldsTHFields :: EntityFieldsTH -> [EntityFieldTH]
..} =
    EntityFieldTH -> EntityFieldTH
stripIdFieldDef EntityFieldTH
entityFieldsTHPrimary forall a. a -> [a] -> [a]
: [EntityFieldTH]
entityFieldsTHFields

stripIdFieldDef :: EntityFieldTH -> EntityFieldTH
stripIdFieldDef :: EntityFieldTH -> EntityFieldTH
stripIdFieldDef EntityFieldTH
efth = EntityFieldTH
efth
    { entityFieldTHClause :: Clause
entityFieldTHClause =
        Clause -> Clause
go (EntityFieldTH -> Clause
entityFieldTHClause EntityFieldTH
efth)
    }
  where
    go :: Clause -> Clause
go (Clause [Pat]
ps Body
bdy [Dec]
ds) =
        [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
ps Body
bdy' [Dec]
ds
      where
        bdy' :: Body
bdy' =
            case Body
bdy of
                NormalB Exp
e ->
                    Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'stripIdFieldImpl) Exp
e
                Body
_ ->
                    Body
bdy

-- | @persistent@ used to assume that an Id was always a single field.
--
-- This method preserves as much backwards compatibility as possible.
stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef
stripIdFieldImpl :: 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 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 =
                forall a. Maybe a
Nothing
            , fieldGenerated :: Maybe Text
fieldGenerated =
                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
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
mkIdField MkPersistSettings
mps UnboundEntityDef
entDef
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings
-> EntityMap
-> UnboundEntityDef
-> UnboundFieldDef
-> Q EntityFieldTH
mkField MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
entDef) (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef)

mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances MkPersistSettings
mps UnboundEntityDef
entDef = do
    Q ()
requirePersistentExtensions
    case EntityDef -> [UniqueDef]
entityUniques (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef) of
        [] -> forall m. Monoid m => m -> m -> m
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
typeErrorSingle forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
typeErrorAtLeastOne
        [UniqueDef
_] -> forall m. Monoid m => m -> m -> m
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
singleUniqueKey forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
atLeastOneKey
        (UniqueDef
_:[UniqueDef]
_) -> forall m. Monoid m => m -> m -> m
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
typeErrorMultiple forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
atLeastOneKey
  where
    requireUniquesPName :: Name
requireUniquesPName = 'requireUniquesP
    onlyUniquePName :: Name
onlyUniquePName = 'onlyUniqueP
    typeErrorSingle :: Q [Dec]
typeErrorSingle = Q [Type] -> Q [Dec]
mkOnlyUniqueError Q [Type]
typeErrorNoneCtx
    typeErrorMultiple :: Q [Dec]
typeErrorMultiple = Q [Type] -> Q [Dec]
mkOnlyUniqueError Q [Type]
typeErrorMultipleCtx

    withPersistStoreWriteCxt :: Q [Type]
withPersistStoreWriteCxt =
        if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
            then do
                Type
write <- [t|PersistStoreWrite $(pure backendT) |]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type
write]
            else do
                forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    typeErrorNoneCtx :: Q [Type]
typeErrorNoneCtx = do
        Type
tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|]
        (Type
tyErr forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
withPersistStoreWriteCxt

    typeErrorMultipleCtx :: Q [Type]
typeErrorMultipleCtx = do
        Type
tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|]
        (Type
tyErr forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
withPersistStoreWriteCxt

    mkOnlyUniqueError :: Q Cxt -> Q [Dec]
    mkOnlyUniqueError :: Q [Type] -> Q [Dec]
mkOnlyUniqueError Q [Type]
mkCtx = do
        [Type]
ctx <- Q [Type]
mkCtx
        let impl :: [Dec]
impl = Name -> [Dec]
mkImpossible Name
onlyUniquePName
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
ctx Type
onlyOneUniqueKeyClass [Dec]
impl]

    mkImpossible :: Name -> [Dec]
mkImpossible Name
name =
        [ Name -> [Clause] -> Dec
FunD Name
name
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                [ Pat
WildP ]
                (Exp -> Body
NormalB
                    (Name -> Exp
VarE 'error Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
"impossible"))
                )
                []
            ]
        ]

    typeErrorAtLeastOne :: Q [Dec]
    typeErrorAtLeastOne :: Q [Dec]
typeErrorAtLeastOne = do
        let impl :: [Dec]
impl = Name -> [Dec]
mkImpossible Name
requireUniquesPName
        [Type]
cxt <- Q [Type]
typeErrorMultipleCtx
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt Type
atLeastOneUniqueKeyClass [Dec]
impl]

    singleUniqueKey :: Q [Dec]
    singleUniqueKey :: Q [Dec]
singleUniqueKey = do
        Exp
expr <- [e| head . persistUniqueKeys|]
        let impl :: [Dec]
impl = [Name -> [Clause] -> Dec
FunD Name
onlyUniquePName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
        [Type]
cxt <- Q [Type]
withPersistStoreWriteCxt
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt Type
onlyOneUniqueKeyClass [Dec]
impl]

    atLeastOneUniqueKeyClass :: Type
atLeastOneUniqueKeyClass = Name -> Type
ConT ''AtLeastOneUniqueKey Type -> Type -> Type
`AppT` Type
genDataType
    onlyOneUniqueKeyClass :: Type
onlyOneUniqueKeyClass =  Name -> Type
ConT ''OnlyOneUniqueKey Type -> Type -> Type
`AppT` Type
genDataType

    atLeastOneKey :: Q [Dec]
    atLeastOneKey :: Q [Dec]
atLeastOneKey = do
        Exp
expr <- [e| NEL.fromList . persistUniqueKeys|]
        let impl :: [Dec]
impl = [Name -> [Clause] -> Dec
FunD Name
requireUniquesPName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
        [Type]
cxt <- Q [Type]
withPersistStoreWriteCxt
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt Type
atLeastOneUniqueKeyClass [Dec]
impl]

    genDataType :: Type
genDataType =
        MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef) Type
backendT

entityText :: UnboundEntityDef -> Text
entityText :: UnboundEntityDef -> Text
entityText = EntityNameHS -> Text
unEntityNameHS 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) = forall (m :: * -> *) a. Monad m => a -> m a
return []
mkLenses MkPersistSettings
_ EntityMap
_ UnboundEntityDef
ent | EntityDef -> Bool
entitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent) = forall (m :: * -> *) a. Monad m => a -> m a
return []
mkLenses MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
ent = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ent forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
fieldNames) forall a b. (a -> b) -> a -> b
$ \(UnboundFieldDef
field, Name
fieldName) -> do
    let lensName :: Name
lensName = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName MkPersistSettings
mps UnboundEntityDef
ent UnboundFieldDef
field
    Name
needleN <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"needle"
    Name
setterN <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"setter"
    Name
fN <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
    Name
aN <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
    Name
yN <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    let needle :: Exp
needle = Name -> Exp
VarE Name
needleN
        setter :: Exp
setter = Name -> Exp
VarE Name
setterN
        f :: Exp
f = Name -> Exp
VarE Name
fN
        a :: Exp
a = Name -> Exp
VarE Name
aN
        y :: Exp
y = Name -> Exp
VarE Name
yN
        fT :: Name
fT = String -> Name
mkName String
"f"
        -- FIXME if we want to get really fancy, then: if this field is the
        -- *only* Id field present, then set backend1 and backend2 to different
        -- values
        backend1 :: Name
backend1 = Name
backendName
        backend2 :: Name
backend2 = Name
backendName
        aT :: Type
aT =
            MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
field (forall a. a -> Maybe a
Just Name
backend1) forall a. Maybe a
Nothing
        bT :: Type
bT =
            MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
field (forall a. a -> Maybe a
Just Name
backend2) forall a. Maybe a
Nothing
        mkST :: Name -> Type
mkST Name
backend =
            MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ent) (Name -> Type
VarT Name
backend)
        sT :: Type
sT = Name -> Type
mkST Name
backend1
        tT :: Type
tT = Name -> Type
mkST Name
backend2
        Type
t1 arrow :: Type -> Type -> Type
`arrow` Type
t2 = Type
ArrowT Type -> Type -> Type
`AppT` Type
t1 Type -> Type -> Type
`AppT` Type
t2
        vars :: [TyVarBndr Specificity]
vars = Name -> TyVarBndr Specificity
mkForallTV Name
fT
             forall a. a -> [a] -> [a]
: (if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps then [Name -> TyVarBndr Specificity
mkForallTV Name
backend1{-, PlainTV backend2-}] else [])
    Exp
fieldUpdClause <- Name -> [Name] -> Exp -> Name -> Exp -> Q Exp
fieldUpd (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ent) [Name]
fieldNames Exp
a Name
fieldName Exp
y
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Name -> Type -> Dec
SigD Name
lensName forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
vars [Name -> [Type] -> Type
mkClassP ''Functor [Name -> Type
VarT Name
fT]] forall a b. (a -> b) -> a -> b
$
            (Type
aT Type -> Type -> Type
`arrow` (Name -> Type
VarT Name
fT Type -> Type -> Type
`AppT` Type
bT)) Type -> Type -> Type
`arrow`
            (Type
sT Type -> Type -> Type
`arrow` (Name -> Type
VarT Name
fT Type -> Type -> Type
`AppT` Type
tT))
        , Name -> [Clause] -> Dec
FunD Name
lensName forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
            [Name -> Pat
VarP Name
fN, Name -> Pat
VarP Name
aN]
            (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp
fmapE
                Exp -> Exp -> Exp
`AppE` Exp
setter
                Exp -> Exp -> Exp
`AppE` (Exp
f Exp -> Exp -> Exp
`AppE` Exp
needle))
            [ Name -> [Clause] -> Dec
FunD Name
needleN [[Pat] -> Exp -> Clause
normalClause [] (Name -> Name -> Exp
fieldSel (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ent) Name
fieldName Exp -> Exp -> Exp
`AppE` Exp
a)]
            , Name -> [Clause] -> Dec
FunD Name
setterN forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
                [Name -> Pat
VarP Name
yN]
                Exp
fieldUpdClause
            ]
        ]
    where
        fieldNames :: [Name]
fieldNames = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
ent 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 n = PlainTV n defaultBndrFlag

mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV n = PlainTV n SpecifiedSpec
#elif MIN_VERSION_template_haskell(2,17,0)
mkPlainTV
    :: Name
    -> TyVarBndr ()
mkPlainTV :: Name -> TyVarBndr ()
mkPlainTV Name
n = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n ()

mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV Name
n = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
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 forall a b. (a -> b) -> a -> b
$ ConstraintNameHS -> FieldNameHS
constraintToField forall a b. (a -> b) -> a -> b
$ ForeignDef -> ConstraintNameHS
foreignConstraintNameHaskell forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef
            reftableString :: String
reftableString =
                Text -> String
unpack forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS forall a b. (a -> b) -> a -> b
$ ForeignDef -> EntityNameHS
foreignRefTableHaskell forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef
            reftableKeyName :: Name
reftableKeyName =
                String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
reftableString forall m. Monoid m => m -> m -> m
`mappend` String
"Key"
            tablename :: Name
tablename =
                UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
entDef
            fieldStore :: FieldStore
fieldStore =
                UnboundEntityDef -> FieldStore
mkFieldStore UnboundEntityDef
entDef

        Name
recordVarName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"record_mkForeignKeysComposite"

        let
            mkFldE :: FieldNameHS -> Exp
mkFldE FieldNameHS
foreignName  =
                -- using coerce here to convince SqlBackendKey to go away
                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 -> Exp
mkFldR ForeignFieldReference
ffr =
                let
                    e :: Exp
e =
                        FieldNameHS -> Exp
mkFldE (ForeignFieldReference -> FieldNameHS
ffrSourceField ForeignFieldReference
ffr)
                in
                    case ForeignFieldReference -> FieldNameHS
ffrTargetField ForeignFieldReference
ffr of
                        FieldNameHS Text
"Id" ->
                            Name -> Exp
VarE 'toBackendKey Exp -> Exp -> Exp
`AppE`
                                Exp
e
                        FieldNameHS
_ ->
                            Exp
e
            foreignFieldNames :: UnboundForeignFieldList -> NonEmpty FieldNameHS
foreignFieldNames UnboundForeignFieldList
foreignFieldList =
                case UnboundForeignFieldList
foreignFieldList of
                    FieldListImpliedId NonEmpty FieldNameHS
names ->
                        NonEmpty FieldNameHS
names
                    FieldListHasReferences NonEmpty ForeignFieldReference
refs ->
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> FieldNameHS
ffrSourceField NonEmpty ForeignFieldReference
refs

            fldsE :: NonEmpty Exp
fldsE =
                UnboundForeignFieldList -> NonEmpty Exp
getForeignNames forall a b. (a -> b) -> a -> b
$ (UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields UnboundForeignDef
foreignDef)
            getForeignNames :: UnboundForeignFieldList -> NonEmpty Exp
getForeignNames = \case
                FieldListImpliedId NonEmpty FieldNameHS
xs ->
                   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldNameHS -> Exp
mkFldE NonEmpty FieldNameHS
xs
                FieldListHasReferences NonEmpty ForeignFieldReference
xs ->
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> Exp
mkFldR NonEmpty ForeignFieldReference
xs

            nullErr :: a -> a
nullErr a
n =
               forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not find field definition for: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
n
            fNullable :: Bool
fNullable =
                NonEmpty UnboundFieldDef -> Bool
setNull
                   forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNameHS
n -> forall a. a -> Maybe a -> a
fromMaybe (forall {a} {a}. Show a => a -> a
nullErr FieldNameHS
n) forall a b. (a -> b) -> a -> b
$ FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef FieldNameHS
n FieldStore
fieldStore)
                   forall a b. (a -> b) -> a -> b
$ UnboundForeignFieldList -> NonEmpty FieldNameHS
foreignFieldNames
                   forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields UnboundForeignDef
foreignDef
            mkKeyE :: Exp
mkKeyE =
                forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Bool -> Exp -> Exp
maybeExp Bool
fNullable forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
reftableKeyName) NonEmpty Exp
fldsE
            fn :: Dec
fn =
                Name -> [Clause] -> Dec
FunD Name
fname [[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
recordVarName] Exp
mkKeyE]

            keyTargetTable :: Type
keyTargetTable =
                Bool -> Type -> Type
maybeTyp Bool
fNullable forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Key Type -> Type -> Type
`AppT` Name -> Type
ConT (String -> Name
mkName String
reftableString)

        Type
sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            [ Name -> Type -> Dec
SigD Name
fname Type
sigTy
            , Dec
fn
            ]

    | Bool
otherwise =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    constraintToField :: ConstraintNameHS -> FieldNameHS
constraintToField = Text -> FieldNameHS
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 forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
columnNames [PersistValue]
fieldsAsPersistValues
    where
        columnNames :: [Text]
columnNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldNameHS -> Text
unFieldNameHS forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell) (EntityDef -> [FieldDef]
getEntityFields (forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (forall a. a -> Maybe a
Just record
entity)))
        fieldsAsPersistValues :: [PersistValue]
fieldsAsPersistValues = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PersistField a => a -> PersistValue
toPersistValue forall a b. (a -> b) -> a -> b
$ forall record. PersistEntity record => record -> [PersistValue]
toPersistFields record
entity

entityFromPersistValueHelper
    :: (PersistEntity record)
    => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code
    -> PersistValue
    -> Either Text record
entityFromPersistValueHelper :: forall record.
PersistEntity record =>
[String] -> PersistValue -> Either Text record
entityFromPersistValueHelper [String]
columnNames PersistValue
pv = do
    ([(Text, PersistValue)]
persistMap :: [(T.Text, PersistValue)]) <- PersistValue -> Either Text [(Text, PersistValue)]
getPersistMap PersistValue
pv

    let columnMap :: HashMap Text PersistValue
columnMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, PersistValue)]
persistMap
        lookupPersistValueByColumnName :: String -> PersistValue
        lookupPersistValueByColumnName :: String -> PersistValue
lookupPersistValueByColumnName String
columnName =
            forall a. a -> Maybe a -> a
fromMaybe PersistValue
PersistNull (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (String -> Text
pack String
columnName) HashMap Text PersistValue
columnMap)

    forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PersistValue
lookupPersistValueByColumnName [String]
columnNames

-- | Produce code similar to the following:
--
-- @
--   instance PersistEntity e => PersistField e where
--      toPersistValue = entityToPersistValueHelper
--      fromPersistValue = entityFromPersistValueHelper ["col1", "col2"]
--      sqlType _ = SqlString
-- @
persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps UnboundEntityDef
entDef = do
    Exp
sqlStringConstructor' <- [|SqlString|]
    Exp
toPersistValueImplementation <- [|entityToPersistValueHelper|]
    Exp
fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|]

    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ
            [ Name -> [Clause] -> Dec
FunD 'toPersistValue [ [Pat] -> Exp -> Clause
normalClause [] Exp
toPersistValueImplementation ]
            , Name -> [Clause] -> Dec
FunD 'fromPersistValue
                [ [Pat] -> Exp -> Clause
normalClause [] Exp
fromPersistValueImplementation ]
            ]
        , Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ
            [ Exp -> Dec
sqlTypeFunD Exp
sqlStringConstructor'
            ]
        ]
  where
    typ :: Type
typ =
        MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)) Type
backendT
    entFields :: [UnboundFieldDef]
entFields =
        forall a. (a -> Bool) -> [a] -> [a]
filter UnboundFieldDef -> Bool
isHaskellUnboundField forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
    columnNames :: [String]
columnNames =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS) [UnboundFieldDef]
entFields

-- | Apply the given list of functions to the same @EntityDef@s.
--
-- This function is useful for cases such as:
--
-- @
-- share ['mkEntityDefList' "myDefs", 'mkPersist' sqlSettings] ['persistLowerCase'|
--     -- ...
-- |]
-- @
--
-- If you only have a single function, though, you don't need this. The
-- following is redundant:
--
-- @
-- 'share' ['mkPersist' 'sqlSettings'] ['persistLowerCase'|
--      -- ...
-- |]
-- @
--
-- Most functions require a full @['EntityDef']@, which can be provided
-- using @$('discoverEntities')@ for all entites in scope, or defining
-- 'mkEntityDefList' to define a list of entities from the given block.
share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec]
share :: forall a. [[a] -> Q [Dec]] -> [a] -> Q [Dec]
share [[a] -> Q [Dec]]
fs [a]
x = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> b) -> a -> b
$ [a]
x) [[a] -> Q [Dec]]
fs

-- | Creates a declaration for the @['EntityDef']@ from the @persistent@
-- schema. This is necessary because the Persistent QuasiQuoter is unable
-- to know the correct type of ID fields, and assumes that they are all
-- Int64.
--
-- Provide this in the list you give to 'share', much like @'mkMigrate'@.
--
-- @
-- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...]
-- @
--
-- @since 2.7.1
mkEntityDefList
    :: String
    -- ^ The name that will be given to the 'EntityDef' list.
    -> [UnboundEntityDef]
    -> Q [Dec]
mkEntityDefList :: String -> [UnboundEntityDef] -> Q [Dec]
mkEntityDefList String
entityList [UnboundEntityDef]
entityDefs = do
    let entityListName :: Name
entityListName = String -> Name
mkName String
entityList
    Exp
edefs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnboundEntityDef]
entityDefs
        forall a b. (a -> b) -> a -> b
$ \UnboundEntityDef
entDef ->
            let entityType :: Q Type
entityType = UnboundEntityDef -> Q Type
entityDefConT UnboundEntityDef
entDef
             in [|entityDef (Proxy :: Proxy $(entityType))|]
    Type
typ <- [t|[EntityDef]|]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Name -> Type -> Dec
SigD Name
entityListName Type
typ
        , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
entityListName) (Exp -> Body
NormalB Exp
edefs) []
        ]

mkUniqueKeys :: UnboundEntityDef -> Q Dec
mkUniqueKeys :: UnboundEntityDef -> Q Dec
mkUniqueKeys UnboundEntityDef
def | EntityDef -> Bool
entitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] ([Exp] -> Exp
ListE [])]
mkUniqueKeys UnboundEntityDef
def = do
    Clause
c <- Q Clause
clause
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [Clause
c]
  where
    clause :: Q Clause
clause = do
        [(FieldNameHS, Name)]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
def) forall a b. (a -> b) -> a -> b
$ \UnboundFieldDef
fieldDef -> do
            let x :: FieldNameHS
x = UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef
            Name
x' <- forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ Char
'_' forall a. a -> [a] -> [a]
: Text -> String
unpack (FieldNameHS -> Text
unFieldNameHS FieldNameHS
x)
            forall (m :: * -> *) a. Monad m => a -> m a
return (FieldNameHS
x, Name
x')
        let pcs :: [Exp]
pcs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(FieldNameHS, Name)] -> UniqueDef -> Exp
go [(FieldNameHS, Name)]
xs) forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def
        let pat :: Pat
pat = Name -> [Pat] -> Pat
conp
                (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
def)
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Pat
VarP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(FieldNameHS, Name)]
xs)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] ([Exp] -> Exp
ListE [Exp]
pcs)

    go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
    go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
go [(FieldNameHS, Name)]
xs (UniqueDef ConstraintNameHS
name ConstraintNameDB
_ NonEmpty ForeignFieldDef
cols [Text]
_) =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' [(FieldNameHS, Name)]
xs) (Name -> Exp
ConE (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
name)) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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' =
                forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"failed in go' while looking up col=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show FieldNameHS
col) (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 -- ^ include PersistStore backend constraint
    -> 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 -- ^ include PersistStore backend constraint
                      -> Type -> [Dec] -> Dec
persistFieldInstanceD :: Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD = Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''PersistField

persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint
                         -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD :: Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD = Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''PersistFieldSql

-- | Automatically creates a valid 'PersistField' instance for any datatype
-- that has valid 'Show' and 'Read' instances. Can be very convenient for
-- 'Enum' types.
derivePersistField :: String -> Q [Dec]
derivePersistField :: String -> Q [Dec]
derivePersistField String
s = do
    Exp
ss <- [|SqlString|]
    Exp
tpv <- [|PersistText . pack . show|]
    Exp
fpv <- [|\dt v ->
                case fromPersistValue v of
                    Left e -> Left e
                    Right s' ->
                        case reads $ unpack s' of
                            (x, _):_ -> Right x
                            [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|]
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD Bool
False (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
            [ Name -> [Clause] -> Dec
FunD 'toPersistValue
                [ [Pat] -> Exp -> Clause
normalClause [] Exp
tpv
                ]
            , Name -> [Clause] -> Dec
FunD 'fromPersistValue
                [ [Pat] -> Exp -> Clause
normalClause [] (Exp
fpv Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
s))
                ]
            ]
        , Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD Bool
False (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
            [ Exp -> Dec
sqlTypeFunD Exp
ss
            ]
        ]

-- | Automatically creates a valid 'PersistField' instance for any datatype
-- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it
-- generates instances similar to these:
--
-- @
--    instance PersistField T where
--        toPersistValue = PersistByteString . L.toStrict . encode
--        fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue
--    instance PersistFieldSql T where
--        sqlType _ = SqlString
-- @
derivePersistFieldJSON :: String -> Q [Dec]
derivePersistFieldJSON :: String -> Q [Dec]
derivePersistFieldJSON String
s = do
    Exp
ss <- [|SqlString|]
    Exp
tpv <- [|PersistText . toJsonText|]
    Exp
fpv <- [|\dt v -> do
                text <- fromPersistValue v
                let bs' = TE.encodeUtf8 text
                case eitherDecodeStrict' bs' of
                    Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs'
                    Right x -> Right x|]
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD Bool
False (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
            [ Name -> [Clause] -> Dec
FunD 'toPersistValue
                [ [Pat] -> Exp -> Clause
normalClause [] Exp
tpv
                ]
            , Name -> [Clause] -> Dec
FunD 'fromPersistValue
                [ [Pat] -> Exp -> Clause
normalClause [] (Exp
fpv Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
s))
                ]
            ]
        , Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD Bool
False (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)
            [ Exp -> Dec
sqlTypeFunD Exp
ss
            ]
        ]

-- | The basic function for migrating models, no Template Haskell required.
--
-- It's probably best to use this in concert with 'mkEntityDefList', and then
-- call 'migrateModels' with the result from that function.
--
-- @
-- share [mkPersist sqlSettings, mkEntityDefList "entities"] [persistLowerCase| ... |]
--
-- migrateAll = 'migrateModels' entities
-- @
--
-- The function 'mkMigrate' currently implements exactly this behavior now. If
-- you're splitting up the entity definitions into separate files, then it is
-- better to use the entity definition list and the concatenate all the models
-- together into a big list to call with 'migrateModels'.
--
-- @
-- module Foo where
--
--     share [mkPersist s, mkEntityDefList "fooModels"] ...
--
--
-- module Bar where
--
--     share [mkPersist s, mkEntityDefList "barModels"] ...
--
-- module Migration where
--
--     import Foo
--     import Bar
--
--     migrateAll = migrateModels (fooModels <> barModels)
-- @
--
-- @since 2.13.0.0
migrateModels :: [EntityDef] -> Migration
migrateModels :: [EntityDef] -> Migration
migrateModels [EntityDef]
defs=
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. (a -> Bool) -> [a] -> [a]
filter EntityDef -> Bool
isMigrated [EntityDef]
defs) 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" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` EntityDef -> [Text]
entityAttrs EntityDef
def

-- | Creates a single function to perform all migrations for the entities
-- defined here. One thing to be aware of is dependencies: if you have entities
-- with foreign references, make sure to place those definitions after the
-- entities they reference.
--
-- In @persistent-2.13.0.0@, this was changed to *ignore* the input entity def
-- list, and instead defer to 'mkEntityDefList' to get the correct entities.
-- This avoids problems where the QuasiQuoter is unable to know what the right
-- reference types are. This sets 'mkPersist' to be the "single source of truth"
-- for entity definitions.
mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec]
mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec]
mkMigrate String
fun [UnboundEntityDef]
eds = do
    let entityDefListName :: String
entityDefListName = (String
"entityDefListFor" forall a. Semigroup a => a -> a -> a
<> String
fun)
    Exp
body <- [| migrateModels $(varE (mkName entityDefListName)) |]
    [Dec]
edList <- String -> [UnboundEntityDef] -> Q [Dec]
mkEntityDefList String
entityDefListName [UnboundEntityDef]
eds
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Dec]
edList forall a. Semigroup a => a -> a -> a
<>
        [ Name -> Type -> Dec
SigD (String -> Name
mkName String
fun) (Name -> Type
ConT ''Migration)
        , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
fun) [[Pat] -> Exp -> Clause
normalClause [] Exp
body]
        ]

data EntityFieldTH = EntityFieldTH
    { EntityFieldTH -> Con
entityFieldTHCon :: Con
    , EntityFieldTH -> Clause
entityFieldTHClause :: Clause
    }

-- Ent
--   fieldName FieldType
--
-- forall . typ ~ FieldType => EntFieldName
--
-- EntFieldName = FieldDef ....
--
-- Field Def Accessors Required:
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 forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ") Type
fieldT]
                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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    Exp
bod <- UnboundEntityDef -> FieldNameHS -> Q Exp
mkLookupEntityField UnboundEntityDef
et (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)
    let cla :: Clause
cla = [Pat] -> Exp -> Clause
normalClause
                [Name -> [Pat] -> Pat
conp Name
name []]
                Exp
bod
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Con -> Clause -> EntityFieldTH
EntityFieldTH Con
con Clause
cla
  where
    name :: Name
name = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps UnboundEntityDef
et UnboundFieldDef
fieldDef

mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
mkIdField MkPersistSettings
mps UnboundEntityDef
ued = do
    let
        entityName :: EntityNameHS
entityName =
            UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ued
        entityIdType :: Type
entityIdType
            | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
                Name -> Type
ConT ''Key Type -> Type -> Type
`AppT` (
                    Name -> Type
ConT (EntityNameHS -> Name
mkEntityNameHSGenericName EntityNameHS
entityName)
                    Type -> Type -> Type
`AppT` Type
backendT
                )
            | Bool
otherwise =
                Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ (Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName) forall m. Monoid m => m -> m -> m
++ String
"Id"
        name :: Name
name =
            MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps EntityNameHS
entityName (Text -> FieldNameHS
FieldNameHS Text
"Id")
    Exp
clause  <-
        MkPersistSettings -> UnboundEntityDef -> Q Exp
fixPrimarySpec MkPersistSettings
mps UnboundEntityDef
ued
    forall (f :: * -> *) a. Applicative f => a -> f a
pure EntityFieldTH
        { entityFieldTHCon :: Con
entityFieldTHCon =
            [TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC
                []
                [Type -> Type -> Type
mkEqualP (Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ") Type
entityIdType]
                forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC Name
name []
        , entityFieldTHClause :: Clause
entityFieldTHClause =
            [Pat] -> Exp -> Clause
normalClause [Name -> [Pat] -> Pat
conp Name
name []] Exp
clause
        }

lookupEntityField
    :: PersistEntity entity
    => Proxy entity
    -> FieldNameHS
    -> FieldDef
lookupEntityField :: forall entity.
PersistEntity entity =>
Proxy entity -> FieldNameHS -> FieldDef
lookupEntityField Proxy entity
prxy FieldNameHS
fieldNameHS =
    forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
boom forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((FieldNameHS
fieldNameHS forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell) forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields forall a b. (a -> b) -> a -> b
$ forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef Proxy entity
prxy
  where
    boom :: a
boom =
        forall a. HasCallStack => String -> a
error String
"Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name"

mkLookupEntityField
    :: UnboundEntityDef
    -> FieldNameHS
    -> Q Exp
mkLookupEntityField :: UnboundEntityDef -> FieldNameHS -> Q Exp
mkLookupEntityField UnboundEntityDef
ued FieldNameHS
ufd =
    [|
        lookupEntityField
            (Proxy :: Proxy $(conT entityName))
            $(lift ufd)
    |]
  where
    entityName :: Name
entityName = EntityNameHS -> Name
mkEntityNameHSName (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ued)

maybeNullable :: UnboundFieldDef -> Bool
maybeNullable :: UnboundFieldDef -> Bool
maybeNullable UnboundFieldDef
fd = UnboundFieldDef -> IsNullable
isUnboundFieldNullable UnboundFieldDef
fd 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 forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
    -- This type is generated from the Quasi-Quoter.
    -- Adding this special case avoids users needing to import Data.Int
    FTTypeCon (Just Text
"Data.Int") Text
"Int64" ->
        Name -> Type
ConT ''Int64
    FTTypeCon (Just Text
m) Text
t ->
        Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Text -> String
unpack 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 forall a b. (a -> b) -> a -> b
$ String -> Name
mkName 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
(++) = forall m. Monoid m => m -> m -> m
mappend

mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON MkPersistSettings
_ UnboundEntityDef
def | (Text
"json" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` EntityDef -> [Text]
entityAttrs (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)) = forall (m :: * -> *) a. Monad m => a -> m a
return []
mkJSON MkPersistSettings
mps (UnboundEntityDef -> UnboundEntityDef
fixEntityDef -> UnboundEntityDef
def) = do
    [[Extension]] -> Q ()
requireExtensions [[Extension
FlexibleInstances]]
    Exp
pureE <- [|pure|]
    Exp
apE' <- [|(<*>)|]

    let objectE :: Exp
objectE = Name -> Exp
VarE 'object
        withObjectE :: Exp
withObjectE = Name -> Exp
VarE 'withObject
        dotEqualE :: Exp
dotEqualE = Name -> Exp
VarE '(.=)
        dotColonE :: Exp
dotColonE = Name -> Exp
VarE '(.:)
        dotColonQE :: Exp
dotColonQE = Name -> Exp
VarE '(.:?)
#if MIN_VERSION_aeson(2,0,0)
        toKeyE :: Exp
toKeyE = Name -> Exp
VarE 'Key.fromString
#else
        toKeyE = VarE 'pack
#endif
    Name
obj <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"obj"
    let
        fields :: [UnboundFieldDef]
fields =
            UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
def

    [Name]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UnboundFieldDef -> Q Name
fieldToJSONValName [UnboundFieldDef]
fields

    let
        conName :: Name
conName =
            UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
def
        typ :: Type
typ =
            MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)) Type
backendT
        toJSONI :: Dec
toJSONI =
            Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''ToJSON (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ [Dec
toJSON']
          where
            toJSON' :: Dec
toJSON' = Name -> [Clause] -> Dec
FunD 'toJSON forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
                [Name -> [Pat] -> Pat
conp Name
conName 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 = 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
                    (forall a. a -> Maybe a
Just (Exp
toKeyE Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ Text -> String
unpack forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
f)))
                    Exp
dotEqualE
                    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x)
        fromJSONI :: Dec
fromJSONI =
            Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''FromJSON (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ [Dec
parseJSON']
          where
            entNameStrLit :: Lit
entNameStrLit =
                String -> Lit
StringL 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]
                    (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                        (\Exp
x Exp
y -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
x) Exp
apE' (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 =
                    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
                    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
obj)
                    (if UnboundFieldDef -> Bool
maybeNullable UnboundFieldDef
f then Exp
dotColonQE else Exp
dotColonE)
                    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
toKeyE forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ Text -> String
unpack forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
f)

    case MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON MkPersistSettings
mps of
        Maybe EntityJSON
Nothing ->
            forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
toJSONI, Dec
fromJSONI]
        Just EntityJSON
entityJSON -> do
            [Dec]
entityJSONIs <- if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
              then [d|
                instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where
                    toJSON = $(varE (entityToJSON entityJSON))
                instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where
                    parseJSON = $(varE (entityFromJSON entityJSON))
                |]
              else [d|
                instance ToJSON (Entity $(pure typ)) where
                    toJSON = $(varE (entityToJSON entityJSON))
                instance FromJSON (Entity $(pure typ)) where
                    parseJSON = $(varE (entityFromJSON entityJSON))
                |]
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dec
toJSONI forall a. a -> [a] -> [a]
: Dec
fromJSONI forall a. a -> [a] -> [a]
: [Dec]
entityJSONIs

mkClassP :: Name -> [Type] -> Pred
mkClassP :: Name -> [Type] -> Type
mkClassP Name
cla [Type]
tys = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
cla) [Type]
tys

mkEqualP :: Type -> Type -> Pred
mkEqualP :: Type -> Type -> Type
mkEqualP Type
tleft Type
tright = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
EqualityT [Type
tleft, Type
tright]

notStrict :: Bang
notStrict :: Bang
notStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

isStrict :: Bang
isStrict :: Bang
isStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict

instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD :: [Type] -> Type -> [Dec] -> Dec
instanceD = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing

-- | Check that all of Persistent's required extensions are enabled, or else fail compilation
--
-- This function should be called before any code that depends on one of the required extensions being enabled.
requirePersistentExtensions :: Q ()
requirePersistentExtensions :: Q ()
requirePersistentExtensions = [[Extension]] -> Q ()
requireExtensions [[Extension]]
requiredExtensions
  where
    requiredExtensions :: [[Extension]]
requiredExtensions = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 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 =
            forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps EntityNameHS
entityHaskellName FieldNameHS
fieldHaskellName
                :: Q Exp
    [[Dec]]
regularFields <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [UnboundFieldDef]
allFields) 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 =
                forall (m :: * -> *). Quote m => m TyLit -> m Type
litT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit
                    forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall {a}. (Eq a, IsString a) => a -> a
lowerFirstIfId
                    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 forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"Id" =
                    forall (m :: * -> *). Quote m => Name -> m Type
conT ''Key forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
recordNameT
                | Bool
otherwise =
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef forall a. Maybe a
Nothing forall a. Maybe a
Nothing
            entityFieldConstr :: Q Exp
entityFieldConstr =
                FieldNameHS -> Q Exp
mkEntityFieldConstr FieldNameHS
fieldHaskellName
        Q Type -> Q Type -> Q Exp -> Q [Dec]
mkInstance Q Type
fieldNameT Q Type
fieldTypeT Q Exp
entityFieldConstr

    [Dec]
mkey <-
        case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
ed of
            NaturalKey UnboundCompositeDef
_ ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            PrimarySpec
_ -> do
                let
                    fieldHaskellName :: FieldNameHS
fieldHaskellName =
                        Text -> FieldNameHS
FieldNameHS Text
"Id"
                    entityFieldConstr :: Q Exp
entityFieldConstr =
                        FieldNameHS -> Q Exp
mkEntityFieldConstr FieldNameHS
fieldHaskellName
                    fieldTypeT :: Q Type
fieldTypeT =
                        forall (m :: * -> *). Quote m => Name -> m Type
conT ''Key forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
recordNameT
                Q Type -> Q Type -> Q Exp -> Q [Dec]
mkInstance [t|"id"|] Q Type
fieldTypeT Q Exp
entityFieldConstr

    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
mkey forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Dec]]
regularFields)
  where
    nameG :: Name
nameG =
        UnboundEntityDef -> Name
mkEntityDefGenericName UnboundEntityDef
ed
    recordNameT :: Q Type
recordNameT
        | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
            forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nameG forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` 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 $(fieldNameT) $(recordNameT) $(fieldTypeT) where
                symbolToField = $(entityFieldConstr)
            |]

-- | Pass in a list of lists of extensions, where any of the given
-- extensions will satisfy it. For example, you might need either GADTs or
-- ExistentialQuantification, so you'd write:
--
-- > requireExtensions [[GADTs, ExistentialQuantification]]
--
-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd
-- write:
--
-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]]
requireExtensions :: [[Extension]] -> Q ()
requireExtensions :: [[Extension]] -> Q ()
requireExtensions [[Extension]]
requiredExtensions = do
  -- isExtEnabled breaks the persistent-template benchmark with the following error:
  -- Template Haskell error: Can't do `isExtEnabled' in the IO monad
  -- You can workaround this by replacing isExtEnabled with (pure . const True)
  [[Extension]]
unenabledExtensions <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Foldable t => t Bool -> Bool
or) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Extension -> Q Bool
isExtEnabled) [[Extension]]
requiredExtensions

  case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. [a] -> Maybe a
listToMaybe [[Extension]]
unenabledExtensions of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Extension
extension] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                     [ String
"Generating Persistent entities now requires the "
                     , 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"
                     , forall a. Show a => a -> String
extensionToPragma Extension
extension
                     ]
    [Extension]
extensions -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                    [ String
"Generating Persistent entities now requires the following language extensions:\n\n"
                    , forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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"
                    , forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
extensionToPragma [Extension]
extensions)
                    ]

  where
    extensionToPragma :: a -> String
extensionToPragma a
ext = String
"{-# LANGUAGE " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
ext forall a. Semigroup a => a -> a -> a
<> String
" #-}"

-- | creates a TH Name for use in the ToJSON instance
fieldToJSONValName :: UnboundFieldDef -> Q Name
fieldToJSONValName :: UnboundFieldDef -> Q Name
fieldToJSONValName =
    forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHSForJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS

-- | This special-cases "type_" and strips out its underscore. When
-- used for JSON serialization and deserialization, it works around
-- <https://github.com/yesodweb/persistent/issues/412>
unFieldNameHSForJSON :: FieldNameHS -> Text
unFieldNameHSForJSON :: FieldNameHS -> Text
unFieldNameHSForJSON = Text -> Text
fixTypeUnderscore 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Name
mkEntityDefName

entityDefConT :: UnboundEntityDef -> Q Type
entityDefConT :: UnboundEntityDef -> Q Type
entityDefConT = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Type
entityDefConK

entityDefConE :: UnboundEntityDef -> Exp
entityDefConE :: UnboundEntityDef -> Exp
entityDefConE = Name -> Exp
ConE forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Name
mkEntityDefName

-- | creates a TH Name for an entity's field, based on the entity
-- name and the field name, so for example:
--
-- Customer
--   name Text
--
-- This would generate `customerName` as a TH Name
fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName :: 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 = forall a. a -> Maybe a
Just Text
"_"
        | Bool
otherwise = forall a. Maybe a
Nothing

-- | as above, only takes a `FieldDef`
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)

-- | creates a TH Name for a lens on an entity's field, based on the entity
-- name and the field name, so as above but for the Lens
--
-- Customer
--   name Text
--
-- Generates a lens `customerName` when `mpsGenerateLenses` is true
-- while `fieldNameToRecordName` generates a prefixed function
-- `_customerName`
mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef =
    MkPersistSettings
-> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
mkRecordName MkPersistSettings
mps 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
avoidKeyword forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
prefix 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
haskellKeywords then Text
name forall m. Monoid m => m -> m -> m
++ Text
"_" else Text
name

haskellKeywords :: Set.Set Text
haskellKeywords :: Set Text
haskellKeywords = 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"
    ]

-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name]
mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name]
mkEntityDefDeriveNames MkPersistSettings
mps UnboundEntityDef
entDef =
    let
        entityInstances :: [Name]
entityInstances =
            String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityDef -> [Text]
entityDerives (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)
        additionalInstances :: [Name]
additionalInstances =
            forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
entityInstances) forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> [Name]
mpsDeriveInstances MkPersistSettings
mps
     in
        [Name]
entityInstances forall a. Semigroup a => a -> a -> a
<> [Name]
additionalInstances

-- | Make a TH Name for the EntityDef's Haskell type
mkEntityNameHSName :: EntityNameHS -> Name
mkEntityNameHSName :: EntityNameHS -> Name
mkEntityNameHSName =
    String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameHS -> Text
unEntityNameHS

-- | As above only taking an `EntityDef`
mkEntityDefName :: UnboundEntityDef -> Name
mkEntityDefName :: UnboundEntityDef -> Name
mkEntityDefName =
    EntityNameHS -> Name
mkEntityNameHSName forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef

-- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric
mkEntityDefGenericName :: UnboundEntityDef -> Name
mkEntityDefGenericName :: UnboundEntityDef -> Name
mkEntityDefGenericName =
    EntityNameHS -> Name
mkEntityNameHSGenericName forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (EntityNameHS -> Text
unEntityNameHS EntityNameHS
name forall a. Semigroup a => a -> a -> a
<> Text
"Generic")

-- needs:
--
-- * entityHaskell
--     * field on EntityDef
-- * fieldHaskell
--     * field on FieldDef
--
sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
unboundFieldDef =
    String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
name
  where
    name :: Text
name
        | MkPersistSettings -> Bool
mpsPrefixFields MkPersistSettings
mps = Text
modifiedName forall m. Monoid m => m -> m -> m
++ Text
"Sum"
        | Bool
otherwise           = Text
fieldName 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 forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef
    fieldName :: Text
fieldName =
        Text -> Text
upperFirst forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldNameHS

-- | Turn a ConstraintName into a TH Name
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack 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) forall m. Monoid m => m -> m -> m
`mappend` Text
"Id"

unKeyName :: UnboundEntityDef -> Name
unKeyName :: UnboundEntityDef -> Name
unKeyName UnboundEntityDef
entDef = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"un" 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"

-- needs:
--
-- * keyText
--     * entityNameHaskell
--  * fields
--      * fieldHaskell
--
-- keyConName :: EntityNameHS -> [FieldHaskell] -> Name
keyConName :: UnboundEntityDef -> Name
keyConName :: UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef =
    EntityNameHS -> [FieldNameHS] -> Name
keyConName'
        (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef)
        (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text
resolveConflict 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 forall m. Monoid m => m -> m -> m
`mappend` Text
"'" else Text
kn
    conflict :: Bool
conflict = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"key") [FieldNameHS]
entFields

-- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp
keyConExp :: UnboundEntityDef -> Exp
keyConExp :: UnboundEntityDef -> Exp
keyConExp UnboundEntityDef
ed = Name -> Exp
ConE 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) forall m. Monoid m => m -> m -> m
++ Text
"Key"

keyText' :: EntityNameHS -> Text
keyText' :: EntityNameHS -> Text
keyText' EntityNameHS
entName = EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text
lowerFirst (UnboundEntityDef -> Text
keyText UnboundEntityDef
entDef) 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 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
name
    where
        name :: Text
name
            | FieldNameHS
field forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"Id" = Text
entityName 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 forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
field

{-|
Splice in a list of all 'EntityDef' in scope. This is useful when running
'mkPersist' to ensure that all entity definitions are available for setting
foreign keys, and for performing migrations with all entities available.

'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to
account for entities defined elsewhere, you'll @mappend $(discoverEntities)@.

For example,

@
share
  [ mkPersistWith sqlSettings $(discoverEntities)
  ]
  [persistLowerCase| ... |]
@

Likewise, to run migrations with all entity instances in scope, you'd write:

@
migrateAll = migrateModels $(discoverEntities)
@

Note that there is some odd behavior with Template Haskell and splicing
groups. If you call 'discoverEntities' in the same module that defines
'PersistEntity' instances, you need to ensure they are in different top-level
binding groups. You can write @$(pure [])@ at the top level to do this.

@
-- Foo and Bar both export an instance of PersistEntity
import Foo
import Bar

-- Since Foo and Bar are both imported, discoverEntities can find them here.
mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase|
  User
    name Text
    age  Int
  |]

-- onlyFooBar is defined in the same 'top level group' as the above generated
-- instance for User, so it isn't present in this list.
onlyFooBar :: [EntityDef]
onlyFooBar = $(discoverEntities)

-- We can manually create a new binding group with this, which splices an
-- empty list of declarations in.
$(pure [])

-- fooBarUser is able to see the 'User' instance.
fooBarUser :: [EntityDef]
fooBarUser = $(discoverEntities)
@

@since 2.13.0.0
-}
discoverEntities :: Q Exp
discoverEntities :: Q Exp
discoverEntities = do
    [Dec]
instances <- Name -> [Type] -> Q [Dec]
reifyInstances ''PersistEntity [Name -> Type
VarT (String -> Name
mkName String
"a")]
    let
        types :: [Type]
types =
            forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe Type
getDecType [Dec]
instances
        getDecType :: Dec -> Maybe Type
getDecType Dec
dec =
            case Dec
dec of
                InstanceD Maybe Overlap
_moverlap [] Type
typ [Dec]
_decs ->
                    Type -> Maybe Type
stripPersistEntity Type
typ
                Dec
_ ->
                    forall a. Maybe a
Nothing
        stripPersistEntity :: Type -> Maybe Type
stripPersistEntity Type
typ =
            case Type
typ of
                AppT (ConT Name
tyName) Type
t | Name
tyName forall a. Eq a => a -> a -> Bool
== ''PersistEntity ->
                    forall a. a -> Maybe a
Just Type
t
                Type
_ ->
                    forall a. Maybe a
Nothing

    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Type]
types forall a b. (a -> b) -> a -> b
$ \Type
typ -> do
            [e| entityDef (Proxy :: Proxy $(pure typ)) |]

setNull :: NonEmpty UnboundFieldDef -> Bool
setNull :: NonEmpty UnboundFieldDef -> Bool
setNull (UnboundFieldDef
fd :| [UnboundFieldDef]
fds) =
    let
        nullSetting :: Bool
nullSetting =
            UnboundFieldDef -> Bool
isNull UnboundFieldDef
fd
        isNull :: UnboundFieldDef -> Bool
isNull =
            (IsNullable
NotNullable forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> IsNullable
isUnboundFieldNullable
    in
        if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Bool
nullSetting forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> Bool
isNull) [UnboundFieldDef]
fds
        then Bool
nullSetting
        else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
            String
"foreign key columns must all be nullable or non-nullable"
           forall m. Monoid m => m -> m -> m
++ forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldNameHS -> Text
unFieldNameHS forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS) (UnboundFieldDef
fdforall a. a -> [a] -> [a]
:[UnboundFieldDef]
fds))