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

    -- | This module provides the tools for defining your database schema and using
    -- it to generate Haskell data types and migrations.
    --
    -- For documentation on the domain specific language used for defining database
    -- models, see "Database.Persist.Quasi".
    module Database.Persist.TH.Internal
        ( -- * Parse entity defs
          persistWith
        , persistUpperCase
        , persistLowerCase
        , persistFileWith
        , persistManyFileWith

          -- * Turn @EntityDef@s into types
        , mkPersist
        , mkPersistWith

          -- ** Configuring Entity Definition
        , MkPersistSettings
        , mkPersistSettings
        , sqlSettings

          -- *** Record Fields (for update/viewing settings)
        , mpsBackend
        , mpsGeneric
        , mpsPrefixFields
        , mpsFieldLabelModifier
        , mpsAvoidHsKeyword
        , mpsConstraintLabelModifier
        , mpsEntityHaddocks
        , mpsEntityJSON
        , mpsGenerateLenses
        , mpsDeriveInstances
        , mpsCamelCaseCompositeKeySelector
        , EntityJSON (..)

          -- ** Implicit ID Columns
        , ImplicitIdDef
        , setImplicitIdDef

          -- * Various other TH functions
        , mkMigrate
        , migrateModels
        , discoverEntities
        , mkEntityDefList
        , share
        , derivePersistField
        , derivePersistFieldJSON
        , persistFieldFromEntity

          -- * Internal
        , lensPTH
        , parseReferences
        , embedEntityDefs
        , fieldError
        , AtLeastOneUniqueKey (..)
        , OnlyOneUniqueKey (..)
        , pkNewtype
        ) where

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

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

    import Control.Monad
    import Data.Aeson
        ( FromJSON (..)
        , ToJSON (..)
        , eitherDecodeStrict'
        , object
        , withObject
        , (.:)
        , (.:?)
        , (.=)
        )
    import Data.Functor.Apply ((<.>))
    #if MIN_VERSION_aeson(2,0,0)
    import qualified Data.Aeson.Key as Key
    #endif
    import qualified Data.ByteString as BS
    import Data.Char (toLower, toUpper)
    import Data.Coerce
    import Data.Data (Data)
    import Data.Either
    import qualified Data.HashMap.Strict as HM
    import Data.Int (Int64)
    import Data.Ix (Ix)
    import qualified Data.List as List
    import Data.List.NonEmpty (NonEmpty (..))
    import qualified Data.List.NonEmpty as NEL
    import qualified Data.Map as M
    import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
    import Data.Proxy (Proxy (Proxy))
    import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack)
    import qualified Data.Text as T
    import Data.Text.Encoding (decodeUtf8)
    import qualified Data.Text.Encoding as TE
    import Data.Typeable (Typeable)
    import GHC.Generics (Generic)
    import GHC.Stack (HasCallStack)
    import GHC.TypeLits
    import Instances.TH.Lift ()

    -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text`
    -- instance on pre-1.2.4 versions of `text`
    import Data.Foldable (asum, toList, traverse_)
    import qualified Data.Set as Set
    import Language.Haskell.TH.Lib
        ( appT
        , conE
        , conK
        , conT
        , litT
        , strTyLit
        , varE
        , varP
        , varT
        )
    #if MIN_VERSION_template_haskell(2,21,0)
    import Language.Haskell.TH.Lib (defaultBndrFlag)
    #endif
    import Language.Haskell.TH.Quote
    import Language.Haskell.TH.Syntax
    import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
    import Web.PathPieces (PathPiece (..))

    import Database.Persist
    import Database.Persist.Class.PersistEntity
    import Database.Persist.Quasi
    import Database.Persist.Quasi.Internal
    import Database.Persist.Quasi.PersistSettings
    import Database.Persist.Sql
        ( Migration
        , PersistFieldSql
        , SqlBackend
        , migrate
        , sqlType
        )

    import Database.Persist.EntityDef.Internal (EntityDef (..))
    import Database.Persist.ImplicitIdDef (autoIncrementingInteger)
    import Database.Persist.ImplicitIdDef.Internal

    #if MIN_VERSION_template_haskell(2,18,0)
    conp :: Name -> [Pat] -> Pat
    conp :: Name -> [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 = \String
    exp -> do
                loc <- Q Loc
    location
                parseReferences ps [(Just $ sourceLocFromTHLoc loc, pack exp)]
            , quotePat :: String -> Q Pat
    quotePat =
                String -> String -> Q Pat
    forall a. HasCallStack => String -> a
    error String
    "persistWith can't be used as pattern"
            , quoteType :: String -> Q Type
    quoteType =
                String -> String -> Q Type
    forall a. HasCallStack => String -> a
    error String
    "persistWith can't be used as type"
            , quoteDec :: String -> Q [Dec]
    quoteDec =
                String -> String -> Q [Dec]
    forall a. HasCallStack => String -> a
    error String
    "persistWith can't be used as declaration"
            }

    -- | 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
        (String -> Q ()) -> [String] -> Q ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ String -> Q ()
    forall (m :: * -> *). Quasi m => String -> m ()
    qAddDependentFile [String]
    fps
        ss <- (String -> Q (String, Text)) -> [String] -> Q [(String, Text)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (\String
    fp -> (String
    fp,) (Text -> (String, Text)) -> Q Text -> Q (String, Text)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (IO Text -> Q Text
    forall a. IO a -> Q a
    forall (m :: * -> *) a. Quasi m => IO a -> m a
    qRunIO (IO Text -> Q Text) -> (String -> IO Text) -> String -> Q Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> IO Text
    getFileContents) String
    fp) [String]
    fps
        parseReferences ps (map (\(String
    fp, Text
    content) -> (SourceLoc -> Maybe SourceLoc
    forall a. a -> Maybe a
    Just (SourceLoc -> Maybe SourceLoc) -> SourceLoc -> Maybe SourceLoc
    forall a b. (a -> b) -> a -> b
    $ String -> SourceLoc
    sourceLoc String
    fp, Text
    content)) ss)
      where
        sourceLoc :: String -> SourceLoc
    sourceLoc String
    path = SourceLoc{locFile :: Text
    locFile = String -> Text
    T.pack String
    path, locStartLine :: Int
    locStartLine = Int
    1, locStartCol :: Int
    locStartCol = Int
    1}

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

    -- | 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 = (EmbedEntityMap, [UnboundEntityDef]) -> [UnboundEntityDef]
    forall a b. (a, b) -> b
    snd ((EmbedEntityMap, [UnboundEntityDef]) -> [UnboundEntityDef])
    -> ([UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef]))
    -> [UnboundEntityDef]
    -> [UnboundEntityDef]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [EntityDef]
    -> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
    embedEntityDefsMap [EntityDef]
    eds

    embedEntityDefsMap
        :: [EntityDef]
        -- ^ 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 = (UnboundEntityDef -> UnboundEntityDef)
    -> [UnboundEntityDef] -> [UnboundEntityDef]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap UnboundEntityDef -> UnboundEntityDef
    setEmbedEntity ([UnboundEntityDef]
    rawEnts [UnboundEntityDef] -> [UnboundEntityDef] -> [UnboundEntityDef]
    forall a. Semigroup a => a -> a -> a
    <> (EntityDef -> UnboundEntityDef)
    -> [EntityDef] -> [UnboundEntityDef]
    forall a b. (a -> b) -> [a] -> [b]
    map EntityDef -> UnboundEntityDef
    unbindEntityDef [EntityDef]
    existingEnts)
        setEmbedEntity :: UnboundEntityDef -> UnboundEntityDef
    setEmbedEntity UnboundEntityDef
    ubEnt =
            let
                ent :: EntityDef
    ent = UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    ubEnt
             in
                UnboundEntityDef
    ubEnt
                    { unboundEntityDef =
                        overEntityFields
                            (fmap (setEmbedField (entityHaskell ent) embedEntityMap))
                            ent
                    }

    -- | Calls 'parse' to Quasi.parse individual entities in isolation
    -- afterwards, sets references to other entities
    --
    -- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@
    -- instead of @['EntityDef']@.
    --
    -- @since 2.16.0.0
    parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp
    parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp
    parseReferences PersistSettings
    ps [(Maybe SourceLoc, Text)]
    s = do
        let
            (Set ParserWarning
    warnings, Either [EntityParseError] [UnboundEntityDef]
    res) = PersistSettings
    -> [(Maybe SourceLoc, Text)]
    -> (Set ParserWarning,
        Either [EntityParseError] [UnboundEntityDef])
    parse PersistSettings
    ps [(Maybe SourceLoc, Text)]
    s
        (ParserWarning -> Q ()) -> Set ParserWarning -> Q ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    (a -> f b) -> t a -> f ()
    traverse_ (String -> Q ()
    reportWarning (String -> Q ())
    -> (ParserWarning -> String) -> ParserWarning -> Q ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ParserWarning -> String
    parserWarningMessage) (Set ParserWarning -> Q ()) -> Set ParserWarning -> Q ()
    forall a b. (a -> b) -> a -> b
    $ Set ParserWarning
    warnings
        case Either [EntityParseError] [UnboundEntityDef]
    res of
            Left [EntityParseError]
    errs -> String -> Q Exp
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [EntityParseError] -> String
    renderErrors [EntityParseError]
    errs
            Right [UnboundEntityDef]
    r -> [UnboundEntityDef] -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => [UnboundEntityDef] -> m Exp
    lift [UnboundEntityDef]
    r

    preprocessUnboundDefs
        :: [EntityDef]
        -> [UnboundEntityDef]
        -> (M.Map EntityNameHS (), [UnboundEntityDef])
    preprocessUnboundDefs :: [EntityDef]
    -> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
    preprocessUnboundDefs [EntityDef]
    preexistingEntities [UnboundEntityDef]
    unboundDefs =
        (EmbedEntityMap
    embedEntityMap, [UnboundEntityDef]
    noCycleEnts)
      where
        (EmbedEntityMap
    embedEntityMap, [UnboundEntityDef]
    noCycleEnts) =
            [EntityDef]
    -> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
    embedEntityDefsMap [EntityDef]
    preexistingEntities [UnboundEntityDef]
    unboundDefs

    liftAndFixKeys
        :: MkPersistSettings
        -> M.Map EntityNameHS a
        -> EntityMap
        -> UnboundEntityDef
        -> Q Exp
    liftAndFixKeys :: forall a.
    MkPersistSettings
    -> Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp
    liftAndFixKeys MkPersistSettings
    mps Map EntityNameHS a
    emEntities EntityMap
    entityMap UnboundEntityDef
    unboundEnt =
        let
            ent :: EntityDef
    ent =
                UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    unboundEnt
            fields :: [UnboundFieldDef]
    fields =
                UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs UnboundEntityDef
    unboundEnt
         in
            [|
                ent
                    { entityFields =
                        $([Exp] -> Exp
    ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (UnboundFieldDef -> Q Exp) -> [UnboundFieldDef] -> Q [Exp]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse UnboundFieldDef -> Q Exp
    combinedFixFieldDef [UnboundFieldDef]
    fields)
                    , entityId =
                        $(MkPersistSettings -> UnboundEntityDef -> Q Exp
    fixPrimarySpec MkPersistSettings
    mps UnboundEntityDef
    unboundEnt)
                    , entityForeigns =
                        $([UnboundForeignDef] -> Q Exp
    fixUnboundForeignDefs (UnboundEntityDef -> [UnboundForeignDef]
    unboundForeignDefs UnboundEntityDef
    unboundEnt))
                    }
                |]
      where
        fixUnboundForeignDefs
            :: [UnboundForeignDef]
            -> Q Exp
        fixUnboundForeignDefs :: [UnboundForeignDef] -> Q Exp
    fixUnboundForeignDefs [UnboundForeignDef]
    fdefs =
            ([Exp] -> Exp) -> Q [Exp] -> Q Exp
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [Exp] -> Exp
    ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [UnboundForeignDef] -> (UnboundForeignDef -> Q Exp) -> Q [Exp]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [UnboundForeignDef]
    fdefs UnboundForeignDef -> Q Exp
    fixUnboundForeignDef
          where
            fixUnboundForeignDef :: UnboundForeignDef -> Q Exp
    fixUnboundForeignDef UnboundForeignDef{ForeignDef
    UnboundForeignFieldList
    unboundForeignFields :: UnboundForeignFieldList
    unboundForeignDef :: ForeignDef
    unboundForeignDef :: UnboundForeignDef -> ForeignDef
    unboundForeignFields :: UnboundForeignDef -> UnboundForeignFieldList
    ..} =
                [|
                    unboundForeignDef
                        { foreignFields =
                            $([(ForeignFieldDef, ForeignFieldDef)] -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *).
    Quote m =>
    [(ForeignFieldDef, ForeignFieldDef)] -> m Exp
    lift [(ForeignFieldDef, ForeignFieldDef)]
    fixForeignFields)
                        , foreignNullable =
                            $(Bool -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => Bool -> m Exp
    lift Bool
    fixForeignNullable)
                        , foreignRefTableDBName =
                            $(EntityNameDB -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => EntityNameDB -> m Exp
    lift EntityNameDB
    fixForeignRefTableDBName)
                        }
                    |]
              where
                fixForeignRefTableDBName :: EntityNameDB
    fixForeignRefTableDBName =
                    EntityDef -> EntityNameDB
    entityDB (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    parentDef)
                foreignFieldNames :: NonEmpty FieldNameHS
    foreignFieldNames =
                    case UnboundForeignFieldList
    unboundForeignFields of
                        FieldListImpliedId NonEmpty FieldNameHS
    ffns ->
                            NonEmpty FieldNameHS
    ffns
                        FieldListHasReferences NonEmpty ForeignFieldReference
    references ->
                            (ForeignFieldReference -> FieldNameHS)
    -> NonEmpty ForeignFieldReference -> NonEmpty FieldNameHS
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ForeignFieldReference -> FieldNameHS
    ffrSourceField NonEmpty ForeignFieldReference
    references
                parentDef :: UnboundEntityDef
    parentDef =
                    case EntityNameHS -> EntityMap -> Maybe UnboundEntityDef
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup EntityNameHS
    parentTableName EntityMap
    entityMap of
                        Maybe UnboundEntityDef
    Nothing ->
                            String -> UnboundEntityDef
    forall a. HasCallStack => String -> a
    error (String -> UnboundEntityDef) -> String -> UnboundEntityDef
    forall a b. (a -> b) -> a -> b
    $
                                [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                                    [ String
    "Foreign table not defined: "
                                    , EntityNameHS -> String
    forall a. Show a => a -> String
    show EntityNameHS
    parentTableName
                                    ]
                        Just UnboundEntityDef
    a ->
                            UnboundEntityDef
    a
                parentTableName :: EntityNameHS
    parentTableName =
                    ForeignDef -> EntityNameHS
    foreignRefTableHaskell ForeignDef
    unboundForeignDef
                fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)]
                fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)]
    fixForeignFields =
                    case UnboundForeignFieldList
    unboundForeignFields of
                        FieldListImpliedId NonEmpty FieldNameHS
    ffns ->
                            [FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)]
    mkReferences ([FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)])
    -> [FieldNameHS] -> [(ForeignFieldDef, ForeignFieldDef)]
    forall a b. (a -> b) -> a -> b
    $ NonEmpty FieldNameHS -> [FieldNameHS]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList NonEmpty FieldNameHS
    ffns
                        FieldListHasReferences NonEmpty ForeignFieldReference
    references ->
                            NonEmpty (ForeignFieldDef, ForeignFieldDef)
    -> [(ForeignFieldDef, ForeignFieldDef)]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (NonEmpty (ForeignFieldDef, ForeignFieldDef)
     -> [(ForeignFieldDef, ForeignFieldDef)])
    -> NonEmpty (ForeignFieldDef, ForeignFieldDef)
    -> [(ForeignFieldDef, ForeignFieldDef)]
    forall a b. (a -> b) -> a -> b
    $ (ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef))
    -> NonEmpty ForeignFieldReference
    -> NonEmpty (ForeignFieldDef, ForeignFieldDef)
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef)
    convReferences NonEmpty ForeignFieldReference
    references
                  where
                    -- 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
                        | [FieldNameHS] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [FieldNameHS]
    fieldNames Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= NonEmpty ForeignFieldDef -> Int
    forall a. NonEmpty a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length NonEmpty ForeignFieldDef
    parentKeyFieldNames =
                            String -> [(ForeignFieldDef, ForeignFieldDef)]
    forall a. HasCallStack => String -> a
    error (String -> [(ForeignFieldDef, ForeignFieldDef)])
    -> String -> [(ForeignFieldDef, ForeignFieldDef)]
    forall a b. (a -> b) -> a -> b
    $
                                [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                                    [ String
    "Foreign reference needs to have the same number "
                                    , String
    "of fields as the target table."
                                    , String
    "\n  Table        : "
                                    , EntityNameHS -> String
    forall a. Show a => a -> String
    show (UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    unboundEnt)
                                    , String
    "\n  Foreign Table: "
                                    , EntityNameHS -> String
    forall a. Show a => a -> String
    show EntityNameHS
    parentTableName
                                    , String
    "\n  Fields       : "
                                    , [FieldNameHS] -> String
    forall a. Show a => a -> String
    show [FieldNameHS]
    fieldNames
                                    , String
    "\n  Parent fields: "
                                    , NonEmpty FieldNameHS -> String
    forall a. Show a => a -> String
    show ((ForeignFieldDef -> FieldNameHS)
    -> NonEmpty ForeignFieldDef -> NonEmpty FieldNameHS
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ForeignFieldDef -> FieldNameHS
    forall a b. (a, b) -> a
    fst NonEmpty ForeignFieldDef
    parentKeyFieldNames)
                                    , String
    "\n\nYou can use the References keyword to fix this."
                                    ]
                        | Bool
    otherwise =
                            [ForeignFieldDef]
    -> [ForeignFieldDef] -> [(ForeignFieldDef, ForeignFieldDef)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((FieldNameHS -> ForeignFieldDef)
    -> [FieldNameHS] -> [ForeignFieldDef]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (FieldStore -> FieldNameHS -> ForeignFieldDef
    withDbName FieldStore
    fieldStore) [FieldNameHS]
    fieldNames) (NonEmpty ForeignFieldDef -> [ForeignFieldDef]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList NonEmpty ForeignFieldDef
    parentKeyFieldNames)
                      where
                        parentKeyFieldNames
                            :: NonEmpty (FieldNameHS, FieldNameDB)
                        parentKeyFieldNames :: NonEmpty ForeignFieldDef
    parentKeyFieldNames =
                            case UnboundEntityDef -> PrimarySpec
    unboundPrimarySpec UnboundEntityDef
    parentDef of
                                NaturalKey UnboundCompositeDef
    ucd ->
                                    (FieldNameHS -> ForeignFieldDef)
    -> NonEmpty FieldNameHS -> NonEmpty ForeignFieldDef
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (FieldStore -> FieldNameHS -> ForeignFieldDef
    withDbName FieldStore
    parentFieldStore) (UnboundCompositeDef -> NonEmpty FieldNameHS
    unboundCompositeCols UnboundCompositeDef
    ucd)
                                SurrogateKey UnboundIdDef
    uid ->
                                    ForeignFieldDef -> NonEmpty ForeignFieldDef
    forall a. a -> NonEmpty a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Text -> FieldNameHS
    FieldNameHS Text
    "Id", UnboundIdDef -> FieldNameDB
    unboundIdDBName UnboundIdDef
    uid)
                                DefaultKey FieldNameDB
    dbName ->
                                    ForeignFieldDef -> NonEmpty ForeignFieldDef
    forall a. a -> NonEmpty a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Text -> FieldNameHS
    FieldNameHS Text
    "Id", FieldNameDB
    dbName)
                    withDbName :: FieldStore -> FieldNameHS -> ForeignFieldDef
    withDbName FieldStore
    store FieldNameHS
    fieldNameHS =
                        ( FieldNameHS
    fieldNameHS
                        , FieldStore -> FieldNameHS -> FieldNameDB
    findDBName FieldStore
    store FieldNameHS
    fieldNameHS
                        )
                    convReferences
                        :: ForeignFieldReference
                        -> (ForeignFieldDef, ForeignFieldDef)
                    convReferences :: ForeignFieldReference -> (ForeignFieldDef, ForeignFieldDef)
    convReferences ForeignFieldReference{FieldNameHS
    ffrSourceField :: ForeignFieldReference -> FieldNameHS
    ffrSourceField :: FieldNameHS
    ffrTargetField :: FieldNameHS
    ffrTargetField :: ForeignFieldReference -> FieldNameHS
    ..} =
                        ( FieldStore -> FieldNameHS -> ForeignFieldDef
    withDbName FieldStore
    fieldStore FieldNameHS
    ffrSourceField
                        , FieldStore -> FieldNameHS -> ForeignFieldDef
    withDbName FieldStore
    parentFieldStore FieldNameHS
    ffrTargetField
                        )
                fixForeignNullable :: Bool
    fixForeignNullable =
                    (FieldNameHS -> Bool) -> NonEmpty FieldNameHS -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ((IsNullable
    NotNullable IsNullable -> IsNullable -> Bool
    forall a. Eq a => a -> a -> Bool
    /=) (IsNullable -> Bool)
    -> (FieldNameHS -> IsNullable) -> FieldNameHS -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FieldNameHS -> IsNullable
    isForeignNullable) NonEmpty FieldNameHS
    foreignFieldNames
                  where
                    isForeignNullable :: FieldNameHS -> IsNullable
    isForeignNullable FieldNameHS
    fieldNameHS =
                        case FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
    getFieldDef FieldNameHS
    fieldNameHS FieldStore
    fieldStore of
                            Maybe UnboundFieldDef
    Nothing ->
                                String -> IsNullable
    forall a. HasCallStack => String -> a
    error String
    "Field name not present in map"
                            Just UnboundFieldDef
    a ->
                                UnboundFieldDef -> IsNullable
    isUnboundFieldNullable UnboundFieldDef
    a

                fieldStore :: FieldStore
    fieldStore =
                    UnboundEntityDef -> FieldStore
    mkFieldStore UnboundEntityDef
    unboundEnt
                parentFieldStore :: FieldStore
    parentFieldStore =
                    UnboundEntityDef -> FieldStore
    mkFieldStore UnboundEntityDef
    parentDef
                findDBName :: FieldStore -> FieldNameHS -> FieldNameDB
    findDBName FieldStore
    store FieldNameHS
    fieldNameHS =
                    case FieldNameHS -> FieldStore -> Maybe FieldNameDB
    getFieldDBName FieldNameHS
    fieldNameHS FieldStore
    store of
                        Maybe FieldNameDB
    Nothing ->
                            String -> FieldNameDB
    forall a. HasCallStack => String -> a
    error (String -> FieldNameDB) -> String -> FieldNameDB
    forall a b. (a -> b) -> a -> b
    $
                                [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                                    [ String
    "findDBName: failed to fix dbname for: "
                                    , FieldNameHS -> String
    forall a. Show a => a -> String
    show FieldNameHS
    fieldNameHS
                                    ]
                        Just FieldNameDB
    a ->
                            FieldNameDB
    a

        combinedFixFieldDef :: UnboundFieldDef -> Q Exp
        combinedFixFieldDef :: UnboundFieldDef -> Q Exp
    combinedFixFieldDef ufd :: UnboundFieldDef
    ufd@UnboundFieldDef{Bool
    [FieldAttr]
    Maybe Text
    FieldNameHS
    FieldNameDB
    FieldCascade
    FieldType
    unboundFieldNameHS :: FieldNameHS
    unboundFieldNameDB :: FieldNameDB
    unboundFieldAttrs :: [FieldAttr]
    unboundFieldStrict :: Bool
    unboundFieldType :: FieldType
    unboundFieldCascade :: FieldCascade
    unboundFieldGenerated :: Maybe Text
    unboundFieldComments :: Maybe Text
    unboundFieldComments :: UnboundFieldDef -> Maybe Text
    unboundFieldGenerated :: UnboundFieldDef -> Maybe Text
    unboundFieldCascade :: UnboundFieldDef -> FieldCascade
    unboundFieldType :: UnboundFieldDef -> FieldType
    unboundFieldStrict :: UnboundFieldDef -> Bool
    unboundFieldAttrs :: UnboundFieldDef -> [FieldAttr]
    unboundFieldNameDB :: UnboundFieldDef -> FieldNameDB
    unboundFieldNameHS :: UnboundFieldDef -> FieldNameHS
    ..} =
            [|
                FieldDef
                    { fieldHaskell =
                        unboundFieldNameHS
                    , fieldDB =
                        unboundFieldNameDB
                    , fieldType =
                        unboundFieldType
                    , fieldSqlType =
                        $(Q Exp
    sqlTyp')
                    , fieldAttrs =
                        unboundFieldAttrs
                    , fieldStrict =
                        unboundFieldStrict
                    , fieldReference =
                        $(Q Exp
    fieldRef')
                    , fieldCascade =
                        unboundFieldCascade
                    , fieldComments =
                        unboundFieldComments
                    , fieldGenerated =
                        unboundFieldGenerated
                    , fieldIsImplicitIdColumn =
                        False
                    }
                |]
          where
            sqlTypeExp :: SqlTypeExp
    sqlTypeExp =
                Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
    forall a.
    Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
    getSqlType Map EntityNameHS a
    emEntities EntityMap
    entityMap UnboundFieldDef
    ufd
            FieldDef FieldNameHS
    _x FieldNameDB
    _ FieldType
    _ SqlType
    _ [FieldAttr]
    _ Bool
    _ ReferenceDef
    _ FieldCascade
    _ Maybe Text
    _ Maybe Text
    _ Bool
    _ =
                String -> FieldDef
    forall a. HasCallStack => String -> a
    error String
    "need to update this record wildcard match"
            (Q Exp
    fieldRef', Q Exp
    sqlTyp') =
                case EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
    extractForeignRef EntityMap
    entityMap UnboundFieldDef
    ufd of
                    Just EntityNameHS
    targetTable ->
                        let
                            targetTableQualified :: EntityNameHS
    targetTableQualified =
                                EntityNameHS -> Maybe EntityNameHS -> EntityNameHS
    forall a. a -> Maybe a -> a
    fromMaybe EntityNameHS
    targetTable (UnboundFieldDef -> Maybe EntityNameHS
    guessFieldReferenceQualified UnboundFieldDef
    ufd)
                         in
                            ( ReferenceDef -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => ReferenceDef -> m Exp
    lift (EntityNameHS -> ReferenceDef
    ForeignRef EntityNameHS
    targetTable)
                            , SqlTypeExp -> Q Exp
    liftSqlTypeExp (EntityNameHS -> SqlTypeExp
    SqlTypeReference EntityNameHS
    targetTableQualified)
                            )
                    Maybe EntityNameHS
    Nothing ->
                        (ReferenceDef -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => ReferenceDef -> m Exp
    lift ReferenceDef
    NoReference, SqlTypeExp -> Q Exp
    liftSqlTypeExp SqlTypeExp
    sqlTypeExp)

    data FieldStore
        = FieldStore
        { FieldStore -> Map FieldNameHS UnboundFieldDef
    fieldStoreMap :: M.Map FieldNameHS UnboundFieldDef
        , FieldStore -> Maybe FieldNameDB
    fieldStoreId :: Maybe FieldNameDB
        , FieldStore -> UnboundEntityDef
    fieldStoreEntity :: UnboundEntityDef
        }

    mkFieldStore :: UnboundEntityDef -> FieldStore
    mkFieldStore :: UnboundEntityDef -> FieldStore
    mkFieldStore UnboundEntityDef
    ued =
        FieldStore
            { fieldStoreEntity :: UnboundEntityDef
    fieldStoreEntity = UnboundEntityDef
    ued
            , fieldStoreMap :: Map FieldNameHS UnboundFieldDef
    fieldStoreMap =
                [(FieldNameHS, UnboundFieldDef)] -> Map FieldNameHS UnboundFieldDef
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList
                    ([(FieldNameHS, UnboundFieldDef)]
     -> Map FieldNameHS UnboundFieldDef)
    -> [(FieldNameHS, UnboundFieldDef)]
    -> Map FieldNameHS UnboundFieldDef
    forall a b. (a -> b) -> a -> b
    $ (UnboundFieldDef -> (FieldNameHS, UnboundFieldDef))
    -> [UnboundFieldDef] -> [(FieldNameHS, UnboundFieldDef)]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap
                        ( \UnboundFieldDef
    ufd ->
                            ( UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    ufd
                            , UnboundFieldDef
    ufd
                            )
                        )
                    ([UnboundFieldDef] -> [(FieldNameHS, UnboundFieldDef)])
    -> [UnboundFieldDef] -> [(FieldNameHS, UnboundFieldDef)]
    forall a b. (a -> b) -> a -> b
    $ UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs
                    (UnboundEntityDef -> [UnboundFieldDef])
    -> UnboundEntityDef -> [UnboundFieldDef]
    forall a b. (a -> b) -> a -> b
    $ UnboundEntityDef
    ued
            , fieldStoreId :: Maybe FieldNameDB
    fieldStoreId =
                case UnboundEntityDef -> PrimarySpec
    unboundPrimarySpec UnboundEntityDef
    ued of
                    NaturalKey UnboundCompositeDef
    _ ->
                        Maybe FieldNameDB
    forall a. Maybe a
    Nothing
                    SurrogateKey UnboundIdDef
    fd ->
                        FieldNameDB -> Maybe FieldNameDB
    forall a. a -> Maybe a
    Just (FieldNameDB -> Maybe FieldNameDB)
    -> FieldNameDB -> Maybe FieldNameDB
    forall a b. (a -> b) -> a -> b
    $ UnboundIdDef -> FieldNameDB
    unboundIdDBName UnboundIdDef
    fd
                    DefaultKey FieldNameDB
    n ->
                        FieldNameDB -> Maybe FieldNameDB
    forall a. a -> Maybe a
    Just FieldNameDB
    n
            }

    getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB
    getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB
    getFieldDBName FieldNameHS
    name FieldStore
    fs
        | Text -> FieldNameHS
    FieldNameHS Text
    "Id" FieldNameHS -> FieldNameHS -> Bool
    forall a. Eq a => a -> a -> Bool
    == FieldNameHS
    name =
            FieldStore -> Maybe FieldNameDB
    fieldStoreId FieldStore
    fs
        | Bool
    otherwise =
            UnboundFieldDef -> FieldNameDB
    unboundFieldNameDB (UnboundFieldDef -> FieldNameDB)
    -> Maybe UnboundFieldDef -> Maybe FieldNameDB
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
    getFieldDef FieldNameHS
    name FieldStore
    fs

    getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
    getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
    getFieldDef FieldNameHS
    fieldNameHS FieldStore
    fs =
        FieldNameHS
    -> Map FieldNameHS UnboundFieldDef -> Maybe UnboundFieldDef
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup FieldNameHS
    fieldNameHS (FieldStore -> Map FieldNameHS UnboundFieldDef
    fieldStoreMap FieldStore
    fs)

    extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
    extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
    extractForeignRef EntityMap
    entityMap UnboundFieldDef
    fieldDef = do
        refName <- UnboundFieldDef -> Maybe EntityNameHS
    guessFieldReference UnboundFieldDef
    fieldDef
        ent <- M.lookup refName entityMap
        pure $ entityHaskell $ unboundEntityDef ent

    guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
    guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
    guessFieldReference = FieldType -> Maybe EntityNameHS
    guessReference (FieldType -> Maybe EntityNameHS)
    -> (UnboundFieldDef -> FieldType)
    -> UnboundFieldDef
    -> Maybe EntityNameHS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundFieldDef -> FieldType
    unboundFieldType

    guessReference :: FieldType -> Maybe EntityNameHS
    guessReference :: FieldType -> Maybe EntityNameHS
    guessReference FieldType
    ft =
        Text -> EntityNameHS
    EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe FieldType -> Maybe Text
    guessReferenceText (FieldType -> Maybe FieldType
    forall a. a -> Maybe a
    Just FieldType
    ft)
      where
        checkIdSuffix :: Text -> Maybe Text
    checkIdSuffix =
            Text -> Text -> Maybe Text
    T.stripSuffix Text
    "Id"
        guessReferenceText :: Maybe FieldType -> Maybe Text
    guessReferenceText Maybe FieldType
    mft =
            [Maybe Text] -> Maybe Text
    forall (t :: * -> *) (f :: * -> *) a.
    (Foldable t, Alternative f) =>
    t (f a) -> f a
    asum
                [ do
                    FTTypeCon _ (checkIdSuffix -> Just tableName) <- Maybe FieldType
    mft
                    pure tableName
                , do
                    FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- Maybe FieldType
    mft
                    pure tableName
                , do
                    FTApp (FTTypeCon _ "Maybe") next <- Maybe FieldType
    mft
                    guessReferenceText (Just next)
                ]

    guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS
    guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS
    guessFieldReferenceQualified = FieldType -> Maybe EntityNameHS
    guessReferenceQualified (FieldType -> Maybe EntityNameHS)
    -> (UnboundFieldDef -> FieldType)
    -> UnboundFieldDef
    -> Maybe EntityNameHS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundFieldDef -> FieldType
    unboundFieldType

    guessReferenceQualified :: FieldType -> Maybe EntityNameHS
    guessReferenceQualified :: FieldType -> Maybe EntityNameHS
    guessReferenceQualified FieldType
    ft =
        Text -> EntityNameHS
    EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe FieldType -> Maybe Text
    guessReferenceText (FieldType -> Maybe FieldType
    forall a. a -> Maybe a
    Just FieldType
    ft)
      where
        checkIdSuffix :: Text -> Maybe Text
    checkIdSuffix =
            Text -> Text -> Maybe Text
    T.stripSuffix Text
    "Id"
        guessReferenceText :: Maybe FieldType -> Maybe Text
    guessReferenceText Maybe FieldType
    mft =
            [Maybe Text] -> Maybe Text
    forall (t :: * -> *) (f :: * -> *) a.
    (Foldable t, Alternative f) =>
    t (f a) -> f a
    asum
                [ do
                    FTTypeCon mmod (checkIdSuffix -> Just tableName) <- Maybe FieldType
    mft
                    -- handle qualified name.
                    pure $ maybe tableName (\Text
    qualName -> Text
    qualName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "." Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    tableName) mmod
                , do
                    FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- Maybe FieldType
    mft
                    -- handle qualified name.
                    pure $ maybe tableName (\Text
    qualName -> Text
    qualName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "." Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    tableName) mmod
                , do
                    FTApp (FTTypeCon _ "Maybe") next <- Maybe FieldType
    mft
                    guessReferenceText (Just next)
                ]

    mkDefaultKey
        :: MkPersistSettings
        -> FieldNameDB
        -> EntityNameHS
        -> FieldDef
    mkDefaultKey :: MkPersistSettings -> FieldNameDB -> EntityNameHS -> FieldDef
    mkDefaultKey MkPersistSettings
    mps FieldNameDB
    pk EntityNameHS
    unboundHaskellName =
        let
            iid :: ImplicitIdDef
    iid =
                MkPersistSettings -> ImplicitIdDef
    mpsImplicitIdDef MkPersistSettings
    mps
         in
            (FieldDef -> FieldDef)
    -> (FieldAttr -> FieldDef -> FieldDef)
    -> Maybe FieldAttr
    -> FieldDef
    -> FieldDef
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe FieldDef -> FieldDef
    forall a. a -> a
    id FieldAttr -> FieldDef -> FieldDef
    addFieldAttr (Text -> FieldAttr
    FieldAttrDefault (Text -> FieldAttr) -> Maybe Text -> Maybe FieldAttr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ImplicitIdDef -> Maybe Text
    iidDefault ImplicitIdDef
    iid) (FieldDef -> FieldDef) -> FieldDef -> FieldDef
    forall a b. (a -> b) -> a -> b
    $
                (FieldDef -> FieldDef)
    -> (FieldAttr -> FieldDef -> FieldDef)
    -> Maybe FieldAttr
    -> FieldDef
    -> FieldDef
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe FieldDef -> FieldDef
    forall a. a -> a
    id FieldAttr -> FieldDef -> FieldDef
    addFieldAttr (Integer -> FieldAttr
    FieldAttrMaxlen (Integer -> FieldAttr) -> Maybe Integer -> Maybe FieldAttr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ImplicitIdDef -> Maybe Integer
    iidMaxLen ImplicitIdDef
    iid) (FieldDef -> FieldDef) -> FieldDef -> FieldDef
    forall a b. (a -> b) -> a -> b
    $
                    FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
    mkAutoIdField' FieldNameDB
    pk EntityNameHS
    unboundHaskellName (ImplicitIdDef -> SqlType
    iidFieldSqlType ImplicitIdDef
    iid)

    fixPrimarySpec
        :: MkPersistSettings
        -> UnboundEntityDef
        -> Q Exp
    fixPrimarySpec :: MkPersistSettings -> UnboundEntityDef -> Q Exp
    fixPrimarySpec MkPersistSettings
    mps UnboundEntityDef
    unboundEnt = do
        case UnboundEntityDef -> PrimarySpec
    unboundPrimarySpec UnboundEntityDef
    unboundEnt of
            DefaultKey FieldNameDB
    pk ->
                EntityIdDef -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => EntityIdDef -> m Exp
    lift (EntityIdDef -> Q Exp) -> EntityIdDef -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
                    FieldDef -> EntityIdDef
    EntityIdField (FieldDef -> EntityIdDef) -> FieldDef -> EntityIdDef
    forall a b. (a -> b) -> a -> b
    $
                        MkPersistSettings -> FieldNameDB -> EntityNameHS -> FieldDef
    mkDefaultKey MkPersistSettings
    mps FieldNameDB
    pk EntityNameHS
    unboundHaskellName
            SurrogateKey UnboundIdDef
    uid -> do
                let
                    entNameHS :: EntityNameHS
    entNameHS =
                        UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    unboundEnt
                    fieldTyp :: FieldType
    fieldTyp =
                        FieldType -> Maybe FieldType -> FieldType
    forall a. a -> Maybe a -> a
    fromMaybe (EntityNameHS -> FieldType
    mkKeyConType EntityNameHS
    entNameHS) (UnboundIdDef -> Maybe FieldType
    unboundIdType UnboundIdDef
    uid)
                [|
                    EntityIdField
                        FieldDef
                            { fieldHaskell =
                                FieldNameHS "Id"
                            , fieldDB =
                                $(FieldNameDB -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => FieldNameDB -> m Exp
    lift (FieldNameDB -> Q Exp) -> FieldNameDB -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ FieldNameDB -> [FieldAttr] -> FieldNameDB
    getSqlNameOr (UnboundIdDef -> FieldNameDB
    unboundIdDBName UnboundIdDef
    uid) (UnboundIdDef -> [FieldAttr]
    unboundIdAttrs UnboundIdDef
    uid))
                            , fieldType =
                                $(FieldType -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => FieldType -> m Exp
    lift FieldType
    fieldTyp)
                            , fieldSqlType =
                                $(SqlTypeExp -> Q Exp
    liftSqlTypeExp (FieldType -> SqlTypeExp
    SqlTypeExp FieldType
    fieldTyp))
                            , fieldStrict =
                                False
                            , fieldReference =
                                ForeignRef entNameHS
                            , fieldAttrs =
                                unboundIdAttrs uid
                            , fieldComments =
                                Nothing
                            , fieldCascade = unboundIdCascade uid
                            , fieldGenerated = Nothing
                            , fieldIsImplicitIdColumn = True
                            }
                    |]
            NaturalKey UnboundCompositeDef
    ucd ->
                [|EntityIdNaturalKey $(UnboundEntityDef -> UnboundCompositeDef -> Q Exp
    bindCompositeDef UnboundEntityDef
    unboundEnt UnboundCompositeDef
    ucd)|]
      where
        unboundHaskellName :: EntityNameHS
    unboundHaskellName =
            UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    unboundEnt

    bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
    bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
    bindCompositeDef UnboundEntityDef
    ued UnboundCompositeDef
    ucd = do
        fieldDefs <-
            ([Exp] -> Exp) -> Q [Exp] -> Q Exp
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [Exp] -> Exp
    ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [FieldNameHS] -> (FieldNameHS -> Q Exp) -> Q [Exp]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM (NonEmpty FieldNameHS -> [FieldNameHS]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (NonEmpty FieldNameHS -> [FieldNameHS])
    -> NonEmpty FieldNameHS -> [FieldNameHS]
    forall a b. (a -> b) -> a -> b
    $ UnboundCompositeDef -> NonEmpty FieldNameHS
    unboundCompositeCols UnboundCompositeDef
    ucd) ((FieldNameHS -> Q Exp) -> Q [Exp])
    -> (FieldNameHS -> Q Exp) -> Q [Exp]
    forall a b. (a -> b) -> a -> b
    $ \FieldNameHS
    col ->
                UnboundEntityDef -> FieldNameHS -> Q Exp
    mkLookupEntityField UnboundEntityDef
    ued FieldNameHS
    col
        [|
            CompositeDef
                { compositeFields =
                    NEL.fromList $(pure fieldDefs)
                , compositeAttrs =
                    $(lift $ unboundCompositeAttrs ucd)
                }
            |]

    getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
    getSqlType :: forall a.
    Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
    getSqlType Map EntityNameHS a
    emEntities EntityMap
    entityMap UnboundFieldDef
    field =
        SqlTypeExp -> (Text -> SqlTypeExp) -> Maybe Text -> SqlTypeExp
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe
            (Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
    forall a.
    Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
    defaultSqlTypeExp Map EntityNameHS a
    emEntities EntityMap
    entityMap UnboundFieldDef
    field)
            (SqlType -> SqlTypeExp
    SqlType' (SqlType -> SqlTypeExp) -> (Text -> SqlType) -> Text -> SqlTypeExp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> SqlType
    SqlOther)
            ([Text] -> Maybe Text
    forall a. [a] -> Maybe a
    listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
    forall a b. (a -> b) -> a -> b
    $ (FieldAttr -> Maybe Text) -> [FieldAttr] -> [Text]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe FieldAttr -> Maybe Text
    attrSqlType ([FieldAttr] -> [Text]) -> [FieldAttr] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ UnboundFieldDef -> [FieldAttr]
    unboundFieldAttrs UnboundFieldDef
    field)

    -- 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 Map EntityNameHS a
    -> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a.
    Map EntityNameHS a
    -> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
    mEmbedded Map EntityNameHS a
    emEntities FieldType
    ftype of
            Right EntityNameHS
    _ ->
                SqlType -> SqlTypeExp
    SqlType' SqlType
    SqlString
            Left (Just (FTKeyCon Text
    ty)) ->
                FieldType -> SqlTypeExp
    SqlTypeExp (Maybe Text -> Text -> FieldType
    FTTypeCon Maybe Text
    forall a. Maybe a
    Nothing Text
    ty)
            Left Maybe FTTypeConDescr
    Nothing ->
                case EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
    extractForeignRef EntityMap
    entityMap UnboundFieldDef
    field of
                    Just EntityNameHS
    refName ->
                        case EntityNameHS -> EntityMap -> Maybe UnboundEntityDef
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup EntityNameHS
    refName EntityMap
    entityMap of
                            Maybe UnboundEntityDef
    Nothing ->
                                -- 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 -> Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    x
        FieldAttr
    _ -> Maybe Text
    forall a. Maybe a
    Nothing

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

    liftSqlTypeExp :: SqlTypeExp -> Q Exp
    liftSqlTypeExp :: SqlTypeExp -> Q Exp
    liftSqlTypeExp SqlTypeExp
    ste =
        case SqlTypeExp
    ste of
            SqlType' SqlType
    t ->
                SqlType -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => SqlType -> m Exp
    lift SqlType
    t
            SqlTypeExp FieldType
    ftype -> do
                let
                    typ :: Type
    typ = FieldType -> Type
    ftToType FieldType
    ftype
                    mtyp :: Type
    mtyp = Name -> Type
    ConT ''Proxy Type -> Type -> Type
    `AppT` Type
    typ
                    typedNothing :: Exp
    typedNothing = Exp -> Type -> Exp
    SigE (Name -> Exp
    ConE 'Proxy) Type
    mtyp
                Exp -> Q Exp
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE 'sqlType Exp -> Exp -> Exp
    `AppE` Exp
    typedNothing
            SqlTypeReference EntityNameHS
    entNameHs -> do
                let
                    entNameId :: Name
                    entNameId :: Name
    entNameId =
                        String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack (EntityNameHS -> Text
    unEntityNameHS EntityNameHS
    entNameHs) String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "Id"

                [|sqlType (Proxy :: Proxy $(Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    entNameId))|]

    type EmbedEntityMap = M.Map EntityNameHS ()

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

    type EntityMap = M.Map EntityNameHS UnboundEntityDef

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

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

    -- | 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
    _) =
        Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. a -> Either a b
    Left Maybe FTTypeConDescr
    forall a. Maybe a
    Nothing
    mEmbedded Map EntityNameHS a
    ents (FTTypeCon Maybe Text
    Nothing (Text -> EntityNameHS
    EntityNameHS -> EntityNameHS
    name)) =
        Either (Maybe FTTypeConDescr) EntityNameHS
    -> (a -> Either (Maybe FTTypeConDescr) EntityNameHS)
    -> Maybe a
    -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. a -> Either a b
    Left Maybe FTTypeConDescr
    forall a. Maybe a
    Nothing) (\a
    _ -> EntityNameHS -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. b -> Either a b
    Right EntityNameHS
    name) (Maybe a -> Either (Maybe FTTypeConDescr) EntityNameHS)
    -> Maybe a -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. (a -> b) -> a -> b
    $ EntityNameHS -> Map EntityNameHS a -> Maybe a
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup EntityNameHS
    name Map EntityNameHS a
    ents
    mEmbedded Map EntityNameHS a
    _ (FTTypePromoted Text
    _) =
        Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. a -> Either a b
    Left Maybe FTTypeConDescr
    forall a. Maybe a
    Nothing
    mEmbedded Map EntityNameHS a
    ents (FTList FieldType
    x) =
        Map EntityNameHS a
    -> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a.
    Map EntityNameHS a
    -> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
    mEmbedded Map EntityNameHS a
    ents FieldType
    x
    mEmbedded Map EntityNameHS a
    _ (FTApp (FTTypeCon Maybe Text
    Nothing Text
    "Key") (FTTypeCon Maybe Text
    _ Text
    a)) =
        Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. a -> Either a b
    Left (Maybe FTTypeConDescr
     -> Either (Maybe FTTypeConDescr) EntityNameHS)
    -> Maybe FTTypeConDescr
    -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. (a -> b) -> a -> b
    $ FTTypeConDescr -> Maybe FTTypeConDescr
    forall a. a -> Maybe a
    Just (FTTypeConDescr -> Maybe FTTypeConDescr)
    -> FTTypeConDescr -> Maybe FTTypeConDescr
    forall a b. (a -> b) -> a -> b
    $ Text -> FTTypeConDescr
    FTKeyCon (Text -> FTTypeConDescr) -> Text -> FTTypeConDescr
    forall a b. (a -> b) -> a -> b
    $ Text
    a Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "Id"
    mEmbedded Map EntityNameHS a
    _ (FTApp FieldType
    _ FieldType
    _) =
        Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. a -> Either a b
    Left Maybe FTTypeConDescr
    forall a. Maybe a
    Nothing
    mEmbedded Map EntityNameHS a
    _ (FTLit FieldTypeLit
    _) =
        Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a b. a -> Either a b
    Left Maybe FTTypeConDescr
    forall a. Maybe a
    Nothing

    setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef
    setEmbedField :: forall a.
    EntityNameHS -> Map EntityNameHS a -> FieldDef -> FieldDef
    setEmbedField EntityNameHS
    entName Map EntityNameHS a
    allEntities FieldDef
    field =
        case FieldDef -> ReferenceDef
    fieldReference FieldDef
    field of
            ReferenceDef
    NoReference ->
                ReferenceDef -> FieldDef -> FieldDef
    setFieldReference ReferenceDef
    ref FieldDef
    field
            ReferenceDef
    _ ->
                FieldDef
    field
      where
        ref :: ReferenceDef
    ref =
            case Map EntityNameHS a
    -> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
    forall a.
    Map EntityNameHS a
    -> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
    mEmbedded Map EntityNameHS a
    allEntities (FieldDef -> FieldType
    fieldType FieldDef
    field) of
                Left Maybe FTTypeConDescr
    _ -> ReferenceDef -> Maybe ReferenceDef -> ReferenceDef
    forall a. a -> Maybe a -> a
    fromMaybe ReferenceDef
    NoReference (Maybe ReferenceDef -> ReferenceDef)
    -> Maybe ReferenceDef -> ReferenceDef
    forall a b. (a -> b) -> a -> b
    $ do
                    refEntName <- Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
    forall a. Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
    lookupEmbedEntity Map EntityNameHS a
    allEntities FieldDef
    field
                    pure $ ForeignRef refEntName
                Right EntityNameHS
    em ->
                    if EntityNameHS
    em EntityNameHS -> EntityNameHS -> Bool
    forall a. Eq a => a -> a -> Bool
    /= EntityNameHS
    entName
                        then EntityNameHS -> ReferenceDef
    EmbedRef EntityNameHS
    em
                        else
                            if UnboundFieldDef -> Bool
    maybeNullable (FieldDef -> UnboundFieldDef
    unbindFieldDef FieldDef
    field)
                                then ReferenceDef
    SelfReference
                                else case FieldDef -> FieldType
    fieldType FieldDef
    field of
                                    FTList FieldType
    _ -> ReferenceDef
    SelfReference
                                    FieldType
    _ ->
                                        String -> ReferenceDef
    forall a. HasCallStack => String -> a
    error (String -> ReferenceDef) -> String -> ReferenceDef
    forall a b. (a -> b) -> a -> b
    $
                                            Text -> String
    unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $
                                                EntityNameHS -> Text
    unEntityNameHS EntityNameHS
    entName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    ": a self reference must be a Maybe or List"

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

    -- | 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 ([UnboundEntityDef] -> [UnboundEntityDef])
    -> [UnboundEntityDef] -> [UnboundEntityDef]
    forall a b. (a -> b) -> a -> b
    $
                    (UnboundEntityDef -> UnboundEntityDef)
    -> [UnboundEntityDef] -> [UnboundEntityDef]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
    setDefaultIdFields MkPersistSettings
    mps) ([UnboundEntityDef] -> [UnboundEntityDef])
    -> [UnboundEntityDef] -> [UnboundEntityDef]
    forall a b. (a -> b) -> a -> b
    $
                        [UnboundEntityDef]
    predefs
            entityMap :: EntityMap
    entityMap =
                [UnboundEntityDef] -> EntityMap
    constructEntityMap [UnboundEntityDef]
    allEnts
            preexistingSet :: Set EntityNameHS
    preexistingSet =
                [EntityNameHS] -> Set EntityNameHS
    forall a. Ord a => [a] -> Set a
    Set.fromList ([EntityNameHS] -> Set EntityNameHS)
    -> [EntityNameHS] -> Set EntityNameHS
    forall a b. (a -> b) -> a -> b
    $ (EntityDef -> EntityNameHS) -> [EntityDef] -> [EntityNameHS]
    forall a b. (a -> b) -> [a] -> [b]
    map EntityDef -> EntityNameHS
    getEntityHaskellName [EntityDef]
    preexistingEntities
            newEnts :: [UnboundEntityDef]
    newEnts =
                (UnboundEntityDef -> Bool)
    -> [UnboundEntityDef] -> [UnboundEntityDef]
    forall a. (a -> Bool) -> [a] -> [a]
    filter
                    (\UnboundEntityDef
    e -> UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    e EntityNameHS -> Set EntityNameHS -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.notMember` Set EntityNameHS
    preexistingSet)
                    [UnboundEntityDef]
    allEnts
        ents <- (UnboundEntityDef -> Q Bool)
    -> [UnboundEntityDef] -> Q [UnboundEntityDef]
    forall (m :: * -> *) a.
    Applicative m =>
    (a -> m Bool) -> [a] -> m [a]
    filterM UnboundEntityDef -> Q Bool
    shouldGenerateCode [UnboundEntityDef]
    newEnts
        requireExtensions
            [ [TypeFamilies]
            , [GADTs, ExistentialQuantification]
            , [DerivingStrategies]
            , [GeneralizedNewtypeDeriving]
            , [StandaloneDeriving]
            , [UndecidableInstances]
            , [DataKinds]
            , [FlexibleInstances]
            ]
        persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents
        entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents
        jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents
        uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents
        safeToInsertInstances <- mconcat <$> mapM (mkSafeToInsertInstance mps) ents
        symbolToFieldInstances <-
            fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents
        return $
            mconcat
                [ persistFieldDecs
                , entityDecs
                , jsonDecs
                , uniqueKeyInstances
                , symbolToFieldInstances
                , safeToInsertInstances
                ]

    mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
    mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
    mkSafeToInsertInstance MkPersistSettings
    mps UnboundEntityDef
    ued =
        case UnboundEntityDef -> PrimarySpec
    unboundPrimarySpec UnboundEntityDef
    ued of
            NaturalKey UnboundCompositeDef
    _ ->
                Q [Dec]
    instanceOkay
            SurrogateKey UnboundIdDef
    uidDef -> do
                let
                    attrs :: [FieldAttr]
    attrs =
                        UnboundIdDef -> [FieldAttr]
    unboundIdAttrs UnboundIdDef
    uidDef
                    isDefaultFieldAttr :: FieldAttr -> Bool
    isDefaultFieldAttr = \case
                        FieldAttrDefault Text
    _ ->
                            Bool
    True
                        FieldAttr
    _ ->
                            Bool
    False
                case UnboundIdDef -> Maybe FieldType
    unboundIdType UnboundIdDef
    uidDef of
                    Maybe FieldType
    Nothing ->
                        Q [Dec]
    instanceOkay
                    Just FieldType
    _ ->
                        case (FieldAttr -> Bool) -> [FieldAttr] -> Maybe FieldAttr
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    List.find FieldAttr -> Bool
    isDefaultFieldAttr [FieldAttr]
    attrs of
                            Maybe FieldAttr
    Nothing ->
                                Q [Dec]
    badInstance
                            Just FieldAttr
    _ -> do
                                instanceOkay
            DefaultKey FieldNameDB
    _ ->
                Q [Dec]
    instanceOkay
      where
        typ :: Type
        typ :: Type
    typ = MkPersistSettings -> EntityNameHS -> Type -> Type
    genericDataType MkPersistSettings
    mps (UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    ued) Type
    backendT

        mkInstance :: Maybe Type -> Dec
    mkInstance Maybe Type
    merr =
            Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
    InstanceD
                Maybe Overlap
    forall a. Maybe a
    Nothing
                (([Type] -> [Type])
    -> (Type -> [Type] -> [Type]) -> Maybe Type -> [Type] -> [Type]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [Type] -> [Type]
    forall a. a -> a
    id (:) Maybe Type
    merr [Type]
    withPersistStoreWriteCxt)
                (Name -> Type
    ConT ''SafeToInsert Type -> Type -> Type
    `AppT` Type
    typ)
                []
        instanceOkay :: Q [Dec]
    instanceOkay =
            [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
                [ Maybe Type -> Dec
    mkInstance Maybe Type
    forall a. Maybe a
    Nothing
                ]
        badInstance :: Q [Dec]
    badInstance = do
            err <- [t|TypeError (SafeToInsertErrorMessage $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    typ))|]
            pure
                [ mkInstance (Just err)
                ]

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

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

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

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

    -- | 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 =
                filter isHaskellUnboundField (unboundEntityFields ued)
            }

    -- | Settings that can be passed to the 'mkPersist' (mps) function to control what code is generated.
    -- This is (just) the data type definition, so you will most likely want to use and adapt concrete values
    -- like 'sqlSettings'.
    data MkPersistSettings = MkPersistSettings
        { 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 names (and lens names) for generated entity data types.
        --
        -- Default: appends entity name and field name, equivalent to
        --
        -- @
        -- mpsFieldLabelModifier = \\entityName fieldName -> entityName <> fieldName
        -- @
        --
        -- to avoid duplicate record field collisions.
        --
        -- For example, with default 'sqlSettings' and
        --
        -- @
        -- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'|
        --     Person
        --         name   Text
        --         age    Int
        -- |]
        -- @
        --
        -- it will generate the entity data type
        --
        -- @
        -- Person {
        --     personName :: Text,  -- generated field name
        --     personAge  :: Int    -- generated field name
        -- }
        -- @
        --
        -- Note: this setting is ignored if the deprecated 'mpsPrefixFields' is set to False.
        --
        -- === __Example without entity name__
        --
        -- You may not want the entity name prefix for all fields, so use
        --
        -- @
        -- 'mkPersistWith' ('sqlSettings' { mpsFieldLabelModifier = \\\_entityName fieldName -> fieldName }) [] ['persistLowerCase'|
        --     Person
        --         name   Text
        --         age    Int
        -- |]
        -- @
        --
        -- instead. This will generate the entity data type
        --
        -- @
        -- Person {
        --     name :: Text,
        --     age  :: Int
        -- }
        -- @
        --
        -- When you have multiple entites with the same field name, you might need to
        -- add @{-# LANGUAGE DuplicateRecordFields #-}@ for your code to compile.
        --
        -- @since 2.11.0.0
        , MkPersistSettings -> Text -> Text
    mpsAvoidHsKeyword :: Text -> Text
        -- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords.
        --
        -- Default: suffix "_".
        --
        -- @since 2.14.6.0
        , 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 the deprecated 'mpsPrefixFields' is set to False.
        --
        -- @since 2.11.0.0
        , MkPersistSettings -> Bool
    mpsEntityHaddocks :: Bool
        -- ^ Generate Haddocks from entity documentation comments. Default: False.
        --
        -- @since 2.14.6.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 = iid}

    getImplicitIdType :: MkPersistSettings -> Type
    getImplicitIdType :: MkPersistSettings -> Type
    getImplicitIdType = do
        idDef <- MkPersistSettings -> ImplicitIdDef
    mpsImplicitIdDef
        isGeneric <- mpsGeneric
        backendTy <- mpsBackend
        pure $ iidType idDef isGeneric backendTy

    data EntityJSON = EntityJSON
        { EntityJSON -> Name
    entityToJSON :: Name
        -- ^ 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 = Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    (++)
            , mpsAvoidHsKeyword :: Text -> Text
    mpsAvoidHsKeyword = (Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    "_")
            , mpsConstraintLabelModifier :: Text -> Text -> Text
    mpsConstraintLabelModifier = Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    (++)
            , mpsEntityHaddocks :: Bool
    mpsEntityHaddocks = Bool
    False
            , mpsEntityJSON :: Maybe EntityJSON
    mpsEntityJSON =
                EntityJSON -> Maybe EntityJSON
    forall a. a -> Maybe a
    Just
                    EntityJSON
                        { entityToJSON :: Name
    entityToJSON = 'entityIdToJSON
                        , entityFromJSON :: Name
    entityFromJSON = 'entityIdFromJSON
                        }
            , mpsGenerateLenses :: Bool
    mpsGenerateLenses = Bool
    False
            , mpsDeriveInstances :: [Name]
    mpsDeriveInstances = []
            , mpsImplicitIdDef :: ImplicitIdDef
    mpsImplicitIdDef =
                ImplicitIdDef
    autoIncrementingInteger
            , mpsCamelCaseCompositeKeySelector :: Bool
    mpsCamelCaseCompositeKeySelector = Bool
    False
            }

    -- | Use the 'SqlPersist' backend.
    sqlSettings :: MkPersistSettings
    sqlSettings :: MkPersistSettings
    sqlSettings = Type -> MkPersistSettings
    mkPersistSettings (Type -> MkPersistSettings) -> Type -> MkPersistSettings
    forall a b. (a -> b) -> a -> b
    $ Name -> Type
    ConT ''SqlBackend

    lowerFirst :: Text -> Text
    lowerFirst :: Text -> Text
    lowerFirst Text
    t =
        case Text -> Maybe (Char, Text)
    uncons Text
    t of
            Just (Char
    a, Text
    b) -> Char -> Text -> Text
    cons (Char -> Char
    toLower Char
    a) Text
    b
            Maybe (Char, Text)
    Nothing -> Text
    t

    upperFirst :: Text -> Text
    upperFirst :: Text -> Text
    upperFirst Text
    t =
        case Text -> Maybe (Char, Text)
    uncons Text
    t of
            Just (Char
    a, Text
    b) -> Char -> Text -> Text
    cons (Char -> Char
    toUpper Char
    a) Text
    b
            Maybe (Char, Text)
    Nothing -> Text
    t

    dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec
    dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec
    dataTypeDec MkPersistSettings
    mps EntityMap
    entityMap UnboundEntityDef
    entDef = do
        let
            names :: [Name]
    names =
                MkPersistSettings -> UnboundEntityDef -> [Name]
    mkEntityDefDeriveNames MkPersistSettings
    mps UnboundEntityDef
    entDef

        let
            ([Name]
    stocks, [Name]
    anyclasses) = [Either Name Name] -> ([Name], [Name])
    forall a b. [Either a b] -> ([a], [b])
    partitionEithers ((Name -> Either Name Name) -> [Name] -> [Either Name Name]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Either Name Name
    stratFor [Name]
    names)
        let
            stockDerives :: [DerivClause]
    stockDerives = do
                Bool -> [()]
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Bool
    not ([Name] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    stocks))
                DerivClause -> [DerivClause]
    forall a. a -> [a]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Maybe DerivStrategy -> [Type] -> DerivClause
    DerivClause (DerivStrategy -> Maybe DerivStrategy
    forall a. a -> Maybe a
    Just DerivStrategy
    StockStrategy) ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Type
    ConT [Name]
    stocks))
            anyclassDerives :: [DerivClause]
    anyclassDerives = do
                Bool -> [()]
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Bool
    not ([Name] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    anyclasses))
                DerivClause -> [DerivClause]
    forall a. a -> [a]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Maybe DerivStrategy -> [Type] -> DerivClause
    DerivClause (DerivStrategy -> Maybe DerivStrategy
    forall a. a -> Maybe a
    Just DerivStrategy
    AnyclassStrategy) ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Type
    ConT [Name]
    anyclasses))
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([DerivClause] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [DerivClause]
    anyclassDerives) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ do
            [[Extension]] -> Q ()
    requireExtensions [[Extension
    DeriveAnyClass]]
        let
            dec :: Dec
    dec =
                [Type]
    -> Name
    -> [TyVarBndr BndrVis]
    -> Maybe Type
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataD
                    []
                    Name
    nameFinal
                    [TyVarBndr BndrVis]
    paramsFinal
                    Maybe Type
    forall a. Maybe a
    Nothing
                    [Con]
    constrs
                    ([DerivClause]
    stockDerives [DerivClause] -> [DerivClause] -> [DerivClause]
    forall a. Semigroup a => a -> a -> a
    <> [DerivClause]
    anyclassDerives)
        MkPersistSettings
    -> [((Name, Bang, Type), Maybe Text)]
    -> Name
    -> UnboundEntityDef
    -> Q ()
    forall (t :: * -> *) b c.
    Foldable t =>
    MkPersistSettings
    -> t ((Name, b, c), Maybe Text) -> Name -> UnboundEntityDef -> Q ()
    conditionallyAddEntityHaddocks MkPersistSettings
    mps [((Name, Bang, Type), Maybe Text)]
    cols Name
    nameFinal UnboundEntityDef
    entDef
        Dec -> Q Dec
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Dec
    dec
      where
        stratFor :: Name -> Either Name Name
    stratFor Name
    n =
            if Name
    n Name -> Set Name -> Bool
    forall a. Eq a => a -> Set a -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` Set Name
    stockClasses
                then
                    Name -> Either Name Name
    forall a b. a -> Either a b
    Left Name
    n
                else
                    Name -> Either Name Name
    forall a b. b -> Either a b
    Right Name
    n

        stockClasses :: Set Name
    stockClasses =
            [Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    Set.fromList
                ( (String -> Name) -> [String] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap
                    String -> Name
    mkName
                    [ String
    "Eq"
                    , String
    "Ord"
                    , String
    "Show"
                    , String
    "Read"
                    , String
    "Bounded"
                    , String
    "Enum"
                    , String
    "Ix"
                    , String
    "Generic"
                    , String
    "Data"
                    , String
    "Typeable"
                    ]
                    [Name] -> [Name] -> [Name]
    forall a. Semigroup a => a -> a -> a
    <> [ ''Eq
                       , ''Ord
                       , ''Show
                       , ''Read
                       , ''Bounded
                       , ''Enum
                       , ''Ix
                       , ''Generic
                       , ''Data
                       , ''Typeable
                       ]
                )

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

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

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

        sumCon :: UnboundFieldDef -> Con
    sumCon UnboundFieldDef
    fieldDef =
            Name -> [BangType] -> Con
    NormalC
                (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
    sumConstrName MkPersistSettings
    mps UnboundEntityDef
    entDef UnboundFieldDef
    fieldDef)
                [(Bang
    notStrict, MkPersistSettings
    -> EntityMap
    -> UnboundFieldDef
    -> Maybe Name
    -> Maybe IsNullable
    -> Type
    maybeIdType MkPersistSettings
    mps EntityMap
    entityMap UnboundFieldDef
    fieldDef Maybe Name
    forall a. Maybe a
    Nothing Maybe IsNullable
    forall a. Maybe a
    Nothing)]

    #if MIN_VERSION_template_haskell(2,18,0)
    conditionallyAddEntityHaddocks
        :: Foldable t
        => MkPersistSettings
        -> t ((Name, b, c), Maybe Text)
        -> Name -> UnboundEntityDef -> Q ()
    conditionallyAddEntityHaddocks :: forall (t :: * -> *) b c.
    Foldable t =>
    MkPersistSettings
    -> t ((Name, b, c), Maybe Text) -> Name -> UnboundEntityDef -> Q ()
    conditionallyAddEntityHaddocks MkPersistSettings
    mps t ((Name, b, c), Maybe Text)
    cols Name
    nameFinal UnboundEntityDef
    entDef =
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (MkPersistSettings -> Bool
    mpsEntityHaddocks MkPersistSettings
    mps) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ do
            t ((Name, b, c), Maybe Text)
    -> (((Name, b, c), Maybe Text) -> Q ()) -> Q ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ t ((Name, b, c), Maybe Text)
    cols ((((Name, b, c), Maybe Text) -> Q ()) -> Q ())
    -> (((Name, b, c), Maybe Text) -> Q ()) -> Q ()
    forall a b. (a -> b) -> a -> b
    $ \((Name
    name, b
    _, c
    _), Maybe Text
    maybeComments) -> do
                case Maybe Text
    maybeComments of
                    Just Text
    comment -> Q () -> Q ()
    addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
                        DocLoc -> String -> Q ()
    putDoc (Name -> DocLoc
    DeclDoc Name
    name) (Text -> String
    unpack Text
    comment)
                    Maybe Text
    Nothing -> () -> Q ()
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
            case EntityDef -> Maybe Text
    entityComments (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    entDef) of
                Just Text
    doc -> do
                    Q () -> Q ()
    addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ DocLoc -> String -> Q ()
    putDoc (Name -> DocLoc
    DeclDoc Name
    nameFinal) (Text -> String
    unpack Text
    doc)
                Maybe Text
    _ -> () -> Q ()
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
    #else
    conditionallyAddEntityHaddocks
        :: Foldable t
        => MkPersistSettings
        -> t ((Name, b, c), Maybe Text)
        -> Name -> UnboundEntityDef -> Q ()
    conditionallyAddEntityHaddocks _ _ _ _ =
        pure ()
    #endif

    #if MIN_VERSION_template_haskell(2,15,0)
    uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
    uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
    uniqueTypeDec MkPersistSettings
    mps EntityMap
    entityMap UnboundEntityDef
    entDef =
        [Type]
    -> Maybe [TyVarBndr ()]
    -> Type
    -> Maybe Type
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataInstD
            []
            Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing
            (Type -> Type -> Type
    AppT (Name -> Type
    ConT ''Unique) (MkPersistSettings -> EntityNameHS -> Type -> Type
    genericDataType MkPersistSettings
    mps (UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    entDef) Type
    backendT))
            Maybe Type
    forall a. Maybe a
    Nothing
            ((UniqueDef -> Con) -> [UniqueDef] -> [Con]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (MkPersistSettings
    -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
    mkUnique MkPersistSettings
    mps EntityMap
    entityMap UnboundEntityDef
    entDef) ([UniqueDef] -> [Con]) -> [UniqueDef] -> [Con]
    forall a b. (a -> b) -> a -> b
    $ EntityDef -> [UniqueDef]
    entityUniques (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    entDef))
            []
    #else
    uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
    uniqueTypeDec mps entityMap entDef =
        DataInstD
            []
            ''Unique
            [genericDataType mps (getUnboundEntityNameHS entDef) backendT]
            Nothing
            (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef))
            []
    #endif

    mkUnique
        :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
    mkUnique :: MkPersistSettings
    -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
    mkUnique MkPersistSettings
    mps EntityMap
    entityMap UnboundEntityDef
    entDef (UniqueDef ConstraintNameHS
    constr ConstraintNameDB
    _ NonEmpty ForeignFieldDef
    fields [Text]
    attrs) =
        Name -> [BangType] -> Con
    NormalC (ConstraintNameHS -> Name
    mkConstraintName ConstraintNameHS
    constr) ([BangType] -> Con) -> [BangType] -> Con
    forall a b. (a -> b) -> a -> b
    $ NonEmpty BangType -> [BangType]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList NonEmpty BangType
    types
      where
        types :: NonEmpty BangType
    types =
            (ForeignFieldDef -> BangType)
    -> NonEmpty ForeignFieldDef -> NonEmpty BangType
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap
                ((UnboundFieldDef, IsNullable) -> BangType
    go ((UnboundFieldDef, IsNullable) -> BangType)
    -> (ForeignFieldDef -> (UnboundFieldDef, IsNullable))
    -> ForeignFieldDef
    -> BangType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable))
    -> [UnboundFieldDef] -> Text -> (UnboundFieldDef, IsNullable)
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
    lookup3 (UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs UnboundEntityDef
    entDef) (Text -> (UnboundFieldDef, IsNullable))
    -> (ForeignFieldDef -> Text)
    -> ForeignFieldDef
    -> (UnboundFieldDef, IsNullable)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FieldNameHS -> Text
    unFieldNameHS (FieldNameHS -> Text)
    -> (ForeignFieldDef -> FieldNameHS) -> ForeignFieldDef -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ForeignFieldDef -> FieldNameHS
    forall a b. (a, b) -> a
    fst)
                NonEmpty ForeignFieldDef
    fields

        force :: Bool
    force = Text
    "!force" Text -> [Text] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Text]
    attrs

        go :: (UnboundFieldDef, IsNullable) -> (Strict, Type)
        go :: (UnboundFieldDef, IsNullable) -> BangType
    go (UnboundFieldDef
    _, Nullable WhyNullable
    _) | Bool -> Bool
    not Bool
    force = String -> BangType
    forall a. HasCallStack => String -> a
    error String
    nullErrMsg
        go (UnboundFieldDef
    fd, IsNullable
    y) = (Bang
    notStrict, MkPersistSettings
    -> EntityMap
    -> UnboundFieldDef
    -> Maybe Name
    -> Maybe IsNullable
    -> Type
    maybeIdType MkPersistSettings
    mps EntityMap
    entityMap UnboundFieldDef
    fd Maybe Name
    forall a. Maybe a
    Nothing (IsNullable -> Maybe IsNullable
    forall a. a -> Maybe a
    Just IsNullable
    y))

        lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
        lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
    lookup3 Text
    s [] =
            String -> (UnboundFieldDef, IsNullable)
    forall a. HasCallStack => String -> a
    error (String -> (UnboundFieldDef, IsNullable))
    -> String -> (UnboundFieldDef, IsNullable)
    forall a b. (a -> b) -> a -> b
    $
                Text -> String
    unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $
                    Text
    "Column not found: " Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    s Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    " in unique " Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ ConstraintNameHS -> Text
    unConstraintNameHS ConstraintNameHS
    constr
        lookup3 Text
    x (UnboundFieldDef
    fd : [UnboundFieldDef]
    rest)
            | Text
    x Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == FieldNameHS -> Text
    unFieldNameHS (UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    fd) =
                (UnboundFieldDef
    fd, UnboundFieldDef -> IsNullable
    isUnboundFieldNullable UnboundFieldDef
    fd)
            | Bool
    otherwise =
                Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
    lookup3 Text
    x [UnboundFieldDef]
    rest

        nullErrMsg :: String
    nullErrMsg =
            [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                [ String
    "Error:  By default Persistent disallows NULLables in an uniqueness "
                , String
    "constraint.  The semantics of how NULL interacts with those constraints "
                , String
    "is non-trivial:  most SQL implementations will not consider two NULL "
                , String
    "values to be equal for the purposes of an uniqueness constraint, "
                , String
    "allowing insertion of more than one row with a NULL value for the "
                , String
    "column in question.  If you understand this feature of SQL and still "
                , String
    "intend to add a uniqueness constraint here,    *** Use a \"!force\" "
                , String
    "attribute on the end of the line that defines your uniqueness "
                , String
    "constraint in order to disable this check. ***"
                ]

    -- | 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 =
            Type -> Maybe Type -> Type
    forall a. a -> Maybe a -> a
    fromMaybe (FieldType -> Type
    ftToType (FieldType -> Type) -> FieldType -> Type
    forall a b. (a -> b) -> a -> b
    $ UnboundFieldDef -> FieldType
    unboundFieldType UnboundFieldDef
    fieldDef) (Maybe Type -> Type) -> Maybe Type -> Type
    forall a b. (a -> b) -> a -> b
    $ do
                typ <- EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
    extractForeignRef EntityMap
    entityMap UnboundFieldDef
    fieldDef
                guard ((mpsGeneric mps))
                pure $
                    ConT ''Key
                        `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend)

        -- 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 (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ OccName -> NameFlavour -> Name
    Name (String -> OccName
    OccName (Text -> String
    T.unpack Text
    name)) NameFlavour
    nameFlavor

        -- \| 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
                    fieldTypeNoId <- Text -> Text -> Maybe Text
    stripSuffix Text
    "Id" Text
    fieldTypeText
                    _ <- M.lookup (EntityNameHS fieldTypeNoId) em
                    pure (T.unpack fieldTypeText)
            case Maybe String
    mmodelIdString of
                Maybe String
    Nothing ->
                    Maybe Type -> Q (Maybe Type)
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe Type
    forall a. Maybe a
    Nothing
                Just String
    modelIdString -> do
                    mIdName <- String -> Q (Maybe Name)
    lookupTypeName String
    modelIdString
                    pure $ fmap _removeIdFromTypeSuffix mIdName

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

    backendDataType :: MkPersistSettings -> Type
    backendDataType :: MkPersistSettings -> Type
    backendDataType MkPersistSettings
    mps
        | MkPersistSettings -> Bool
    mpsGeneric MkPersistSettings
    mps = Type
    backendT
        | Bool
    otherwise = MkPersistSettings -> Type
    mpsBackend MkPersistSettings
    mps

    -- | 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 (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ EntityNameHS -> Name
    mkEntityNameHSName EntityNameHS
    name

    degen :: [Clause] -> [Clause]
    degen :: [Clause] -> [Clause]
    degen [] =
        let
            err :: Exp
    err =
                Name -> Exp
    VarE 'error
                    Exp -> Exp -> Exp
    `AppE` Lit -> Exp
    LitE
                        ( String -> Lit
    StringL
                            String
    "Degenerate case, should never happen"
                        )
         in
            [[Pat] -> Exp -> Clause
    normalClause [Pat
    WildP] Exp
    err]
    degen [Clause]
    x = [Clause]
    x

    -- 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
        clauses <-
            if Bool
    isSum
                then [Q Clause] -> Q [Clause]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence ([Q Clause] -> Q [Clause]) -> [Q Clause] -> Q [Clause]
    forall a b. (a -> b) -> a -> b
    $ (UnboundFieldDef -> Int -> Q Clause)
    -> [UnboundFieldDef] -> [Int] -> [Q Clause]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith UnboundFieldDef -> Int -> Q Clause
    goSum [UnboundFieldDef]
    fields [Int
    1 ..]
                else (Clause -> [Clause]) -> Q Clause -> Q [Clause]
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Clause -> [Clause]
    forall a. a -> [a]
    forall (m :: * -> *) a. Monad m => a -> m a
    return Q Clause
    go
        return $ FunD 'toPersistFields clauses
      where
        go :: Q Clause
        go :: Q Clause
    go = do
            xs <- [Q Name] -> Q [Name]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence ([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
    forall a b. (a -> b) -> a -> b
    $ Int -> Q Name -> [Q Name]
    forall a. Int -> a -> [a]
    replicate Int
    fieldCount (Q Name -> [Q Name]) -> Q Name -> [Q Name]
    forall a b. (a -> b) -> a -> b
    $ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
            let
                name = UnboundEntityDef -> Name
    mkEntityDefName UnboundEntityDef
    ed
                pat = Name -> [Pat] -> Pat
    conp Name
    name ([Pat] -> Pat) -> [Pat] -> Pat
    forall a b. (a -> b) -> a -> b
    $ (Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Pat
    VarP [Name]
    xs
            sp <- [|toPersistValue|]
            let
                bod = [Exp] -> Exp
    ListE ([Exp] -> Exp) -> [Exp] -> Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Exp -> Exp -> Exp
    AppE Exp
    sp (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Exp
    VarE) [Name]
    xs
            return $ normalClause [pat] bod

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

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

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

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

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

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

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

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

    lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b
    lensPTH :: forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
    lensPTH s -> a
    sa s -> b -> t
    sbt a -> f b
    afb s
    s = (b -> t) -> f b -> f t
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (s -> b -> t
    sbt s
    s) (a -> f b
    afb (a -> f b) -> a -> f b
    forall a b. (a -> b) -> a -> b
    $ s -> a
    sa s
    s)

    fmapE :: Exp
    fmapE :: Exp
    fmapE = Name -> Exp
    VarE 'fmap

    unboundEntitySum :: UnboundEntityDef -> Bool
    unboundEntitySum :: UnboundEntityDef -> Bool
    unboundEntitySum = EntityDef -> Bool
    entitySum (EntityDef -> Bool)
    -> (UnboundEntityDef -> EntityDef) -> UnboundEntityDef -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundEntityDef -> EntityDef
    unboundEntityDef

    fieldSel :: Name -> Name -> Exp
    fieldSel :: Name -> Name -> Exp
    fieldSel Name
    conName Name
    fieldName =
        [Pat] -> Exp -> Exp
    LamE [Name -> [(Name, Pat)] -> Pat
    RecP Name
    conName [(Name
    fieldName, Name -> Pat
    VarP Name
    xName)]] (Name -> Exp
    VarE Name
    xName)
      where
        xName :: Name
    xName = String -> Name
    mkName String
    "x"

    fieldUpd
        :: Name
        -- ^ 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
        pats <-
            ([[(Name, Pat)]] -> [(Name, Pat)])
    -> Q [[(Name, Pat)]] -> Q [(Name, Pat)]
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [[(Name, Pat)]] -> [(Name, Pat)]
    forall a. Monoid a => [a] -> a
    mconcat (Q [[(Name, Pat)]] -> Q [(Name, Pat)])
    -> Q [[(Name, Pat)]] -> Q [(Name, Pat)]
    forall a b. (a -> b) -> a -> b
    $ [Name] -> (Name -> Q [(Name, Pat)]) -> Q [[(Name, Pat)]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [Name]
    names ((Name -> Q [(Name, Pat)]) -> Q [[(Name, Pat)]])
    -> (Name -> Q [(Name, Pat)]) -> Q [[(Name, Pat)]]
    forall a b. (a -> b) -> a -> b
    $ \Name
    k -> do
                varName <- Name -> Pat
    VarP (Name -> Pat) -> Q Name -> Q Pat
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName (Name -> String
    nameBase Name
    k)
                pure [(k, varName) | k /= name]

        pure $
            CaseE
                record
                [Match (RecP con pats) (NormalB body) []]
      where
        body :: Exp
    body =
            Name -> [FieldExp] -> Exp
    RecConE
                Name
    con
                [ if Name
    k Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    name then (Name
    name, Exp
    new) else (Name
    k, Name -> Exp
    VarE Name
    k)
                | Name
    k <- [Name]
    names
                ]

    mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
    mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
    mkLensClauses MkPersistSettings
    mps UnboundEntityDef
    entDef Type
    _genDataType = do
        lens' <- [|lensPTH|]
        getId <- [|entityKey|]
        setId <- [|\(Entity _ value) key -> Entity key value|]
        getVal <- [|entityVal|]
        dot <- [|(.)|]
        keyVar <- newName "key"
        valName <- newName "value"
        xName <- newName "x"
        let
            idClause =
                [Pat] -> Exp -> Clause
    normalClause
                    [Name -> [Pat] -> Pat
    conp (UnboundEntityDef -> Name
    keyIdName UnboundEntityDef
    entDef) []]
                    (Exp
    lens' Exp -> Exp -> Exp
    `AppE` Exp
    getId Exp -> Exp -> Exp
    `AppE` Exp
    setId)
        (idClause :)
            <$> if unboundEntitySum entDef
                then
                    pure $
                        fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)
                else
                    zipWithM
                        (toClause lens' getVal dot keyVar valName xName)
                        (getUnboundFieldDefs entDef)
                        fieldNames
      where
        fieldNames :: [Name]
    fieldNames = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
    fieldDefToRecordName MkPersistSettings
    mps UnboundEntityDef
    entDef (UnboundFieldDef -> Name) -> [UnboundFieldDef] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs UnboundEntityDef
    entDef
        toClause :: Exp
    -> Exp
    -> Exp
    -> Name
    -> Name
    -> Name
    -> UnboundFieldDef
    -> Name
    -> Q Clause
    toClause Exp
    lens' Exp
    getVal Exp
    dot Name
    keyVar Name
    valName Name
    xName UnboundFieldDef
    fieldDef Name
    fieldName = do
            setter <- Q Exp
    mkSetter
            pure $
                normalClause
                    [conp (filterConName mps entDef fieldDef) []]
                    (lens' `AppE` getter `AppE` setter)
          where
            defName :: Name
    defName = UnboundEntityDef -> Name
    mkEntityDefName UnboundEntityDef
    entDef
            getter :: Exp
    getter = Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Name -> Exp
    fieldSel Name
    defName Name
    fieldName) Exp
    dot (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    getVal)
            mkSetter :: Q Exp
    mkSetter = do
                updExpr <- Name -> [Name] -> Exp -> Name -> Exp -> Q Exp
    fieldUpd Name
    defName [Name]
    fieldNames (Name -> Exp
    VarE Name
    valName) Name
    fieldName (Name -> Exp
    VarE Name
    xName)
                pure
                    $ LamE
                        [ conp 'Entity [VarP keyVar, VarP valName]
                        , VarP xName
                        ]
                    $ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr

        toSumClause :: Exp -> Name -> Name -> Name -> UnboundFieldDef -> Clause
    toSumClause Exp
    lens' Name
    keyVar Name
    valName Name
    xName UnboundFieldDef
    fieldDef =
            [Pat] -> Exp -> Clause
    normalClause
                [Name -> [Pat] -> Pat
    conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
    filterConName MkPersistSettings
    mps UnboundEntityDef
    entDef UnboundFieldDef
    fieldDef) []]
                (Exp
    lens' Exp -> Exp -> Exp
    `AppE` Exp
    getter Exp -> Exp -> Exp
    `AppE` Exp
    setter)
          where
            emptyMatch :: Match
    emptyMatch =
                Pat -> Body -> [Dec] -> Match
    Match
                    Pat
    WildP
                    ( Exp -> Body
    NormalB (Exp -> Body) -> Exp -> Body
    forall a b. (a -> b) -> a -> b
    $
                        Name -> Exp
    VarE 'error Exp -> Exp -> Exp
    `AppE` Lit -> Exp
    LitE (String -> Lit
    StringL String
    "Tried to use fieldLens on a Sum type")
                    )
                    []
            getter :: Exp
    getter =
                [Pat] -> Exp -> Exp
    LamE
                    [ Name -> [Pat] -> Pat
    conp 'Entity [Pat
    WildP, Name -> Pat
    VarP Name
    valName]
                    ]
                    (Exp -> Exp) -> Exp -> Exp
    forall a b. (a -> b) -> a -> b
    $ Exp -> [Match] -> Exp
    CaseE (Name -> Exp
    VarE Name
    valName)
                    ([Match] -> Exp) -> [Match] -> Exp
    forall a b. (a -> b) -> a -> b
    $ Pat -> Body -> [Dec] -> Match
    Match
                        (Name -> [Pat] -> Pat
    conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
    sumConstrName MkPersistSettings
    mps UnboundEntityDef
    entDef UnboundFieldDef
    fieldDef) [Name -> Pat
    VarP Name
    xName])
                        (Exp -> Body
    NormalB (Exp -> Body) -> Exp -> Body
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    xName)
                        []
                        -- FIXME It would be nice if the types expressed that the Field is
                        -- a sum type and therefore could result in Maybe.
                        Match -> [Match] -> [Match]
    forall a. a -> [a] -> [a]
    : if [UnboundFieldDef] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs UnboundEntityDef
    entDef) Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    1 then [Match
    emptyMatch] else []
            setter :: Exp
    setter =
                [Pat] -> Exp -> Exp
    LamE
                    [ Name -> [Pat] -> Pat
    conp 'Entity [Name -> Pat
    VarP Name
    keyVar, Pat
    WildP]
                    , Name -> Pat
    VarP Name
    xName
                    ]
                    (Exp -> Exp) -> Exp -> Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    ConE 'Entity
                        Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    keyVar
                        Exp -> Exp -> Exp
    `AppE` (Name -> Exp
    ConE (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
    sumConstrName MkPersistSettings
    mps UnboundEntityDef
    entDef UnboundFieldDef
    fieldDef) Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    xName)

    -- | 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
        (instDecs, i) <-
            if MkPersistSettings -> Bool
    mpsGeneric MkPersistSettings
    mps
                then
                    if Bool -> Bool
    not Bool
    useNewtype
                        then do
                            pfDec <- Q [Dec]
    pfInstD
                            return (pfDec, supplement [''Generic])
                        else do
                            gi <- Q [Dec]
    genericNewtypeInstances
                            return (gi, supplement [])
                else
                    if Bool -> Bool
    not Bool
    useNewtype
                        then do
                            pfDec <- Q [Dec]
    pfInstD
                            return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])
                        else do
                            let
                                allInstances :: [Name]
    allInstances =
                                    [Name] -> [Name]
    supplement
                                        [ ''Show
                                        , ''Read
                                        , ''Eq
                                        , ''Ord
                                        , ''PathPiece
                                        , ''ToHttpApiData
                                        , ''FromHttpApiData
                                        , ''PersistField
                                        , ''PersistFieldSql
                                        , ''ToJSON
                                        , ''FromJSON
                                        ]
                            if Bool
    customKeyType
                                then ([Dec], [Name]) -> Q ([Dec], [Name])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], [Name]
    allInstances)
                                else do
                                    bi <- Q [Dec]
    backendKeyI
                                    return (bi, allInstances)

        requirePersistentExtensions

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

        let
            kd = Bool -> Name -> Type -> Con -> [DerivClause] -> Dec
    mkKeyDeclaration Bool
    useNewtype Name
    k Type
    recordType Con
    dec [DerivClause]
    deriveClauses
        return (kd, instDecs)
      where
        keyConE :: Exp
    keyConE = UnboundEntityDef -> Exp
    keyConExp UnboundEntityDef
    entDef
        unKeyE :: Exp
    unKeyE = UnboundEntityDef -> Exp
    unKeyExp UnboundEntityDef
    entDef
        dec :: Con
    dec = Name -> [(Name, Bang, Type)] -> Con
    RecC (UnboundEntityDef -> Name
    keyConName UnboundEntityDef
    entDef) (NonEmpty (Name, Bang, Type) -> [(Name, Bang, Type)]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (NonEmpty (Name, Bang, Type) -> [(Name, Bang, Type)])
    -> NonEmpty (Name, Bang, Type) -> [(Name, Bang, Type)]
    forall a b. (a -> b) -> a -> b
    $ MkPersistSettings
    -> UnboundEntityDef -> NonEmpty (Name, Bang, Type)
    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 $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType)) where
                    toPersistValue = PersistList . keyToValues
                    fromPersistValue (PersistList l) = keyFromValues l
                    fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got

                instance PersistFieldSql (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType)) where
                    sqlType _ = SqlString

                instance ToJSON (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                instance FromJSON (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))
                |]

        backendKeyGenericI :: Q [Dec]
    backendKeyGenericI =
            [d|
                instance
                    (PersistStore $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))
                    => ToBackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT) $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType)
                    where
                    toBackendKey = $(Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    unKeyE)
                    fromBackendKey = $(Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    keyConE)
                |]
        backendKeyI :: Q [Dec]
    backendKeyI =
            let
                bdt :: Type
    bdt = MkPersistSettings -> Type
    backendDataType MkPersistSettings
    mps
             in
                [d|
                    instance ToBackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    bdt) $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType) where
                        toBackendKey = $(Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    unKeyE)
                        fromBackendKey = $(Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    keyConE)
                    |]

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

            alwaysInstances <-
                -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here
                [d|
                    deriving stock instance
                        (Show (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))) => Show (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving stock instance
                        (Read (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))) => Read (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (Eq (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))) => Eq (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (Ord (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))) => Ord (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (ToHttpApiData (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT)))
                        => ToHttpApiData (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (FromHttpApiData (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT)))
                        => FromHttpApiData (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (PathPiece (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))) => PathPiece (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (PersistField (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT)))
                        => PersistField (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (PersistFieldSql (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT)))
                        => PersistFieldSql (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (ToJSON (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))) => ToJSON (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))

                    deriving newtype instance
                        (FromJSON (BackendKey $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT))) => FromJSON (Key $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    recordType))
                    |]

            mappend alwaysInstances
                <$> if customKeyType
                    then pure []
                    else backendKeyGenericI

        useNewtype :: Bool
    useNewtype = MkPersistSettings -> UnboundEntityDef -> Bool
    pkNewtype MkPersistSettings
    mps UnboundEntityDef
    entDef
        customKeyType :: Bool
    customKeyType =
            [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or
                [ Bool -> Bool
    not (UnboundEntityDef -> Bool
    defaultIdType UnboundEntityDef
    entDef)
                , Bool -> Bool
    not Bool
    useNewtype
                , Maybe CompositeDef -> Bool
    forall a. Maybe a -> Bool
    isJust (EntityDef -> Maybe CompositeDef
    entityPrimary (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    entDef))
                , Bool -> Bool
    not Bool
    isBackendKey
                ]

        isBackendKey :: Bool
    isBackendKey =
            case MkPersistSettings -> Type
    getImplicitIdType MkPersistSettings
    mps of
                ConT Name
    bk `AppT` Type
    _
                    | Name
    bk Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''BackendKey ->
                        Bool
    True
                Type
    _ ->
                    Bool
    False

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

    #if MIN_VERSION_template_haskell(2,15,0)
    mkKeyDeclaration :: Bool -> Name -> Type -> Con -> [DerivClause] -> Dec
    mkKeyDeclaration :: Bool -> Name -> Type -> Con -> [DerivClause] -> Dec
    mkKeyDeclaration Bool
    useNewtype Name
    k Type
    recordType Con
    dec [DerivClause]
    deriveClauses =
        if Bool
    useNewtype
                   then [Type]
    -> Maybe [TyVarBndr ()]
    -> Type
    -> Maybe Type
    -> Con
    -> [DerivClause]
    -> Dec
    NewtypeInstD [] Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing (Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    k) Type
    recordType) Maybe Type
    forall a. Maybe a
    Nothing Con
    dec [DerivClause]
    deriveClauses
                   else [Type]
    -> Maybe [TyVarBndr ()]
    -> Type
    -> Maybe Type
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataInstD    [] Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing (Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    k) Type
    recordType) Maybe Type
    forall a. Maybe a
    Nothing [Con
    dec] [DerivClause]
    deriveClauses
    #else
    mkKeyDeclaration :: Bool -> Name -> Type -> Con -> [DerivClause] -> Dec
    mkKeyDeclaration useNewtype k recordType dec deriveClauses =
        if useNewtype
                   then NewtypeInstD [] k [recordType] Nothing dec deriveClauses
                   else DataInstD    [] k [recordType] Nothing [dec] deriveClauses
    #endif

    -- | Returns 'True' if the key definition has less than 2 fields.
    --
    -- @since 2.11.0.0
    pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
    pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
    pkNewtype MkPersistSettings
    mps UnboundEntityDef
    entDef = NonEmpty (Name, Bang, Type) -> Int
    forall a. NonEmpty a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (MkPersistSettings
    -> UnboundEntityDef -> NonEmpty (Name, Bang, Type)
    keyFields MkPersistSettings
    mps UnboundEntityDef
    entDef) Int -> Int -> Bool
    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 (Name, Bang, Type)
    keyFields MkPersistSettings
    mps UnboundEntityDef
    entDef =
        case UnboundEntityDef -> PrimarySpec
    unboundPrimarySpec UnboundEntityDef
    entDef of
            NaturalKey UnboundCompositeDef
    ucd ->
                (FieldNameHS -> (Name, Bang, Type))
    -> NonEmpty FieldNameHS -> NonEmpty (Name, Bang, Type)
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap FieldNameHS -> (Name, Bang, Type)
    naturalKeyVar (UnboundCompositeDef -> NonEmpty FieldNameHS
    unboundCompositeCols UnboundCompositeDef
    ucd)
            DefaultKey FieldNameDB
    _ ->
                (Name, Bang, Type) -> NonEmpty (Name, Bang, Type)
    forall a. a -> NonEmpty a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ((Name, Bang, Type) -> NonEmpty (Name, Bang, Type))
    -> (Type -> (Name, Bang, Type))
    -> Type
    -> NonEmpty (Name, Bang, Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> (Name, Bang, Type)
    idKeyVar (Type -> NonEmpty (Name, Bang, Type))
    -> Type -> NonEmpty (Name, Bang, Type)
    forall a b. (a -> b) -> a -> b
    $ MkPersistSettings -> Type
    getImplicitIdType MkPersistSettings
    mps
            SurrogateKey UnboundIdDef
    k ->
                (Name, Bang, Type) -> NonEmpty (Name, Bang, Type)
    forall a. a -> NonEmpty a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ((Name, Bang, Type) -> NonEmpty (Name, Bang, Type))
    -> (Type -> (Name, Bang, Type))
    -> Type
    -> NonEmpty (Name, Bang, Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> (Name, Bang, Type)
    idKeyVar (Type -> NonEmpty (Name, Bang, Type))
    -> Type -> NonEmpty (Name, Bang, Type)
    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 -> (Name, Bang, Type)
    naturalKeyVar FieldNameHS
    fieldName =
            case FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
    findField FieldNameHS
    fieldName [UnboundFieldDef]
    unboundFieldDefs of
                Maybe UnboundFieldDef
    Nothing ->
                    String -> (Name, Bang, Type)
    forall a. HasCallStack => String -> a
    error String
    "column not defined on entity"
                Just UnboundFieldDef
    unboundFieldDef ->
                    ( MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
    keyFieldName MkPersistSettings
    mps UnboundEntityDef
    entDef (UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    unboundFieldDef)
                    , Bang
    notStrict
                    , FieldType -> Type
    ftToType (FieldType -> Type) -> FieldType -> Type
    forall a b. (a -> b) -> a -> b
    $ UnboundFieldDef -> FieldType
    unboundFieldType UnboundFieldDef
    unboundFieldDef
                    )

        idKeyVar :: Type -> (Name, Bang, Type)
    idKeyVar Type
    ft =
            ( UnboundEntityDef -> Name
    unKeyName UnboundEntityDef
    entDef
            , Bang
    notStrict
            , Type
    ft
            )

    findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
    findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
    findField FieldNameHS
    fieldName =
        (UnboundFieldDef -> Bool)
    -> [UnboundFieldDef] -> Maybe UnboundFieldDef
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    List.find ((FieldNameHS
    fieldName FieldNameHS -> FieldNameHS -> Bool
    forall a. Eq a => a -> a -> Bool
    ==) (FieldNameHS -> Bool)
    -> (UnboundFieldDef -> FieldNameHS) -> UnboundFieldDef -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS)

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

    normalClause :: [Pat] -> Exp -> Clause
    normalClause :: [Pat] -> Exp -> Clause
    normalClause [Pat]
    p Exp
    e = [Pat] -> Body -> [Dec] -> Clause
    Clause [Pat]
    p (Exp -> Body
    NormalB Exp
    e) []

    -- needs:
    --

    -- * entityPrimary

    -- * keyConExp entDef
    mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
    mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
    mkKeyFromValues MkPersistSettings
    _mps UnboundEntityDef
    entDef =
        Name -> [Clause] -> Dec
    FunD 'keyFromValues
            ([Clause] -> Dec) -> Q [Clause] -> Q Dec
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> case UnboundEntityDef -> PrimarySpec
    unboundPrimarySpec UnboundEntityDef
    entDef of
                NaturalKey UnboundCompositeDef
    ucd ->
                    UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
    fromValues UnboundEntityDef
    entDef Text
    "keyFromValues" Exp
    keyConE (NonEmpty FieldNameHS -> [FieldNameHS]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (NonEmpty FieldNameHS -> [FieldNameHS])
    -> NonEmpty FieldNameHS -> [FieldNameHS]
    forall a b. (a -> b) -> a -> b
    $ UnboundCompositeDef -> NonEmpty FieldNameHS
    unboundCompositeCols UnboundCompositeDef
    ucd)
                PrimarySpec
    _ -> do
                    e <- [|fmap $(Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    keyConE) . fromPersistValue . headNote|]
                    return [normalClause [] e]
      where
        keyConE :: Exp
    keyConE = UnboundEntityDef -> Exp
    keyConExp UnboundEntityDef
    entDef

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

    -- 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
        x <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
        let
            funMsg =
                [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat
                    [ UnboundEntityDef -> Text
    entityText UnboundEntityDef
    entDef
                    , Text
    ": "
                    , Text
    funName
                    , Text
    " failed on: "
                    ]
        patternMatchFailure <-
            [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
        suc <- patternSuccess
        return [suc, normalClause [VarP x] patternMatchFailure]
      where
        tableName :: Text
    tableName =
            EntityNameDB -> Text
    unEntityNameDB (EntityDef -> EntityNameDB
    entityDB (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    entDef))
        patternSuccess :: Q Clause
    patternSuccess =
            case [FieldNameHS]
    fields of
                [] -> do
                    rightE <- [|Right|]
                    return $ normalClause [ListP []] (rightE `AppE` constructExpr)
                [FieldNameHS]
    _ -> do
                    x1 <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x1"
                    restNames <- mapM (\Int
    i -> String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName (String -> Q Name) -> String -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String
    "x" String -> String -> String
    forall m. Monoid m => m -> m -> m
    `mappend` Int -> String
    forall a. Show a => a -> String
    show Int
    i) [2 .. length fields]
                    (fpv1 : mkPersistValues) <- mapM mkPersistValue fields
                    app1E <- [|(<$>)|]
                    let
                        conApp = Exp -> Exp -> Exp -> Name -> Exp
    infixFromPersistValue Exp
    app1E Exp
    fpv1 Exp
    constructExpr Name
    x1
                    applyE <- [|(<*>)|]
                    let
                        applyFromPersistValue = Exp -> Exp -> Exp -> Name -> Exp
    infixFromPersistValue Exp
    applyE

                    return $
                        normalClause
                            [ListP $ fmap VarP (x1 : restNames)]
                            ( List.foldl'
                                (\Exp
    exp (Name
    name, Exp
    fpv) -> Exp -> Exp -> Name -> Exp
    applyFromPersistValue Exp
    fpv Exp
    exp Name
    name)
                                conApp
                                (zip restNames mkPersistValues)
                            )

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

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

    -- |  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 =
        [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat
            [ Text
    "Couldn't parse field `"
            , Text
    fieldName
            , Text
    "` from table `"
            , Text
    tableName
            , Text
    "`. "
            , Text
    err
            ]

    mkEntity
        :: M.Map EntityNameHS a
        -> EntityMap
        -> MkPersistSettings
        -> UnboundEntityDef
        -> Q [Dec]
    mkEntity :: forall a.
    Map EntityNameHS a
    -> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
    mkEntity Map EntityNameHS a
    embedEntityMap EntityMap
    entityMap MkPersistSettings
    mps UnboundEntityDef
    preDef = do
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (EntityDef -> Bool
    isEntitySum (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    preDef)) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ do
            String -> Q ()
    reportWarning (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $
                [String] -> String
    unlines
                    [ String
    "persistent has deprecated sum type entities as of 2.14.0.0."
                    , String
    "We will delete support for these entities in 2.15.0.0."
                    , String
    "If you need these, please add a comment on this GitHub issue:"
                    , String
    ""
                    , String
    "    https://github.com/yesodweb/persistent/issues/987"
                    ]

        entityDefExp <- MkPersistSettings
    -> Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp
    forall a.
    MkPersistSettings
    -> Map EntityNameHS a -> EntityMap -> UnboundEntityDef -> Q Exp
    liftAndFixKeys MkPersistSettings
    mps Map EntityNameHS a
    embedEntityMap EntityMap
    entityMap UnboundEntityDef
    preDef
        let
            entDef =
                UnboundEntityDef -> UnboundEntityDef
    fixEntityDef UnboundEntityDef
    preDef
        fields <- mkFields mps entityMap entDef
        let
            name = UnboundEntityDef -> Name
    mkEntityDefName UnboundEntityDef
    entDef
        let
            clazz = Name -> Type
    ConT ''PersistEntity Type -> Type -> Type
    `AppT` Type
    genDataType
        tpf <- mkToPersistFields mps entDef
        fpv <- mkFromPersistValues mps entDef
        utv <- mkUniqueToValues $ entityUniques $ unboundEntityDef entDef
        puk <- mkUniqueKeys entDef
        fkc <- mapM (mkForeignKeysComposite mps entDef) $ unboundForeignDefs entDef

        toFieldNames <- mkToFieldNames $ entityUniques $ unboundEntityDef entDef

        (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef
        keyToValues' <- mkKeyToValues mps entDef
        keyFromValues' <- mkKeyFromValues mps entDef

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

        lensClauses <- mkLensClauses mps entDef genDataType

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

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

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

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

        mkTabulateApply <- do
            fromFieldName <- newName "fromField"
            let
                names'types =
                    ((Name, Type) -> Bool) -> [(Name, Type)] -> [(Name, Type)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(Name
    n, Type
    _) -> Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String -> Name
    mkName String
    "Id") ([(Name, Type)] -> [(Name, Type)])
    -> [(Name, Type)] -> [(Name, Type)]
    forall a b. (a -> b) -> a -> b
    $
                        (EntityFieldTH -> (Name, Type))
    -> [EntityFieldTH] -> [(Name, Type)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Con -> (Name, Type)
    getConNameAndType (Con -> (Name, Type))
    -> (EntityFieldTH -> Con) -> EntityFieldTH -> (Name, Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . EntityFieldTH -> Con
    entityFieldTHCon) ([EntityFieldTH] -> [(Name, Type)])
    -> [EntityFieldTH] -> [(Name, Type)]
    forall a b. (a -> b) -> a -> b
    $
                            EntityFieldsTH -> [EntityFieldTH]
    entityFieldsTHFields EntityFieldsTH
    fields
                getConNameAndType = \case
                    ForallC [] [Type
    EqualityT `AppT` Type
    _ `AppT` Type
    fieldTy] (NormalC Name
    conName []) ->
                        (Name
    conName, Type
    fieldTy)
                    Con
    other ->
                        String -> (Name, Type)
    forall a. HasCallStack => String -> a
    error (String -> (Name, Type)) -> String -> (Name, Type)
    forall a b. (a -> b) -> a -> b
    $
                            [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                                [ String
    "persistent internal error: field constructor did not have xpected shape. \n"
                                , String
    "Expected: \n"
                                , String
    "    ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n"
                                , String
    "Got: \n"
                                , String
    "    " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> Con -> String
    forall a. Show a => a -> String
    show Con
    other
                                ]
                mkEntityVal =
                    (Exp, Exp) -> Exp
    forall a b. (a, b) -> a
    fst ((Exp, Exp) -> Exp) -> (Exp, Exp) -> Exp
    forall a b. (a -> b) -> a -> b
    $
                        ((Exp, Exp) -> (Name, Type) -> (Exp, Exp))
    -> (Exp, Exp) -> [(Name, Type)] -> (Exp, Exp)
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    List.foldl'
                            ( \(Exp
    acc, Exp
    op) (Name
    n, Type
    _) ->
                                ( Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE
                                    (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    acc)
                                    Exp
    op
                                    (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Name -> Exp
    VarE Name
    fromFieldName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    ConE Name
    n))
                                , Name -> Exp
    VarE '(<.>)
                                )
                            )
                            (Name -> Exp
    ConE (EntityNameHS -> Name
    mkEntityNameHSName EntityNameHS
    entName), Name -> Exp
    VarE '(<$>))
                            [(Name, Type)]
    names'types
                primaryKeyField =
                    (Name, Type) -> Name
    forall a b. (a, b) -> a
    fst ((Name, Type) -> Name) -> (Name, Type) -> Name
    forall a b. (a -> b) -> a -> b
    $ Con -> (Name, Type)
    getConNameAndType (Con -> (Name, Type)) -> Con -> (Name, Type)
    forall a b. (a -> b) -> a -> b
    $ EntityFieldTH -> Con
    entityFieldTHCon (EntityFieldTH -> Con) -> EntityFieldTH -> Con
    forall a b. (a -> b) -> a -> b
    $ EntityFieldsTH -> EntityFieldTH
    entityFieldsTHPrimary EntityFieldsTH
    fields
            body <-
                if isEntitySum $ unboundEntityDef entDef
                    then [|error "tabulateEntityApply does not make sense for sum type"|]
                    else
                        if null names'types
                            then
                                [|
                                    (\k -> Entity k $(conE (mkEntityNameHSName entName)))
                                        <$> $(varE fromFieldName) $(conE primaryKeyField)
                                    |]
                            else
                                [|
                                    Entity
                                        <$> $(varE fromFieldName) $(conE primaryKeyField)
                                        <.> $(pure mkEntityVal)
                                    |]

            pure $
                FunD
                    'tabulateEntityApply
                    [ Clause [VarP fromFieldName] (NormalB body) []
                    ]

        mkTabulateA <- do
            fromFieldName <- newName "fromField"
            let
                names'types =
                    ((Name, Type) -> Bool) -> [(Name, Type)] -> [(Name, Type)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(Name
    n, Type
    _) -> Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String -> Name
    mkName String
    "Id") ([(Name, Type)] -> [(Name, Type)])
    -> [(Name, Type)] -> [(Name, Type)]
    forall a b. (a -> b) -> a -> b
    $
                        (EntityFieldTH -> (Name, Type))
    -> [EntityFieldTH] -> [(Name, Type)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Con -> (Name, Type)
    getConNameAndType (Con -> (Name, Type))
    -> (EntityFieldTH -> Con) -> EntityFieldTH -> (Name, Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . EntityFieldTH -> Con
    entityFieldTHCon) ([EntityFieldTH] -> [(Name, Type)])
    -> [EntityFieldTH] -> [(Name, Type)]
    forall a b. (a -> b) -> a -> b
    $
                            EntityFieldsTH -> [EntityFieldTH]
    entityFieldsTHFields EntityFieldsTH
    fields
                getConNameAndType = \case
                    ForallC [] [Type
    EqualityT `AppT` Type
    _ `AppT` Type
    fieldTy] (NormalC Name
    conName []) ->
                        (Name
    conName, Type
    fieldTy)
                    Con
    other ->
                        String -> (Name, Type)
    forall a. HasCallStack => String -> a
    error (String -> (Name, Type)) -> String -> (Name, Type)
    forall a b. (a -> b) -> a -> b
    $
                            [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                                [ String
    "persistent internal error: field constructor did not have xpected shape. \n"
                                , String
    "Expected: \n"
                                , String
    "    ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n"
                                , String
    "Got: \n"
                                , String
    "    " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> Con -> String
    forall a. Show a => a -> String
    show Con
    other
                                ]
                mkEntityVal =
                    (Exp -> (Name, Type) -> Exp) -> Exp -> [(Name, Type)] -> Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    List.foldl'
                        ( \Exp
    acc (Name
    n, Type
    _) ->
                            Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE
                                (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    acc)
                                (Name -> Exp
    VarE '(<*>))
                                (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Name -> Exp
    VarE Name
    fromFieldName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    ConE Name
    n))
                        )
                        (Name -> Exp
    VarE 'pure Exp -> Exp -> Exp
    `AppE` Name -> Exp
    ConE (EntityNameHS -> Name
    mkEntityNameHSName EntityNameHS
    entName))
                        [(Name, Type)]
    names'types
                primaryKeyField =
                    (Name, Type) -> Name
    forall a b. (a, b) -> a
    fst ((Name, Type) -> Name) -> (Name, Type) -> Name
    forall a b. (a -> b) -> a -> b
    $ Con -> (Name, Type)
    getConNameAndType (Con -> (Name, Type)) -> Con -> (Name, Type)
    forall a b. (a -> b) -> a -> b
    $ EntityFieldTH -> Con
    entityFieldTHCon (EntityFieldTH -> Con) -> EntityFieldTH -> Con
    forall a b. (a -> b) -> a -> b
    $ EntityFieldsTH -> EntityFieldTH
    entityFieldsTHPrimary EntityFieldsTH
    fields
            body <-
                if isEntitySum $ unboundEntityDef entDef
                    then [|error "tabulateEntityA does not make sense for sum type"|]
                    else
                        [|
                            Entity
                                <$> $(varE fromFieldName) $(conE primaryKeyField)
                                <*> $(pure mkEntityVal)
                            |]

            pure $
                FunD
                    'tabulateEntityA
                    [ Clause [VarP fromFieldName] (NormalB body) []
                    ]

        return $
            addSyn $
                dtd
                    : mconcat fkc
                        `mappend` ( [ TySynD (keyIdName entDef) [] $
                                        ConT ''Key `AppT` ConT name
                                    , instanceD
                                        instanceConstraint
                                        clazz
                                        [ uniqueTypeDec mps entityMap entDef
                                        , keyTypeDec
                                        , keyToValues'
                                        , keyFromValues'
                                        , keyFromRecordM'
                                        , mkTabulateA
                                        , mkTabulateApply
                                        , FunD 'entityDef [normalClause [WildP] entityDefExp]
                                        , tpf
                                        , FunD 'fromPersistValues fpv
                                        , toFieldNames
                                        , utv
                                        , puk
                                        , mkEntityFieldDataInstance genDataType allEntDefs
                                        , FunD 'persistFieldDef allEntDefClauses
                                        , mkTySynInstanceForBackend mps genDataType
                                        , FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)]
                                        , FunD 'fieldLens lensClauses
                                        ]
                                    ]
                                        `mappend` lenses
                                  )
                        `mappend` keyInstanceDecs
      where
        genDataType :: Type
    genDataType =
            MkPersistSettings -> EntityNameHS -> Type -> Type
    genericDataType MkPersistSettings
    mps EntityNameHS
    entName Type
    backendT
        entName :: EntityNameHS
    entName =
            UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    preDef

    #if MIN_VERSION_template_haskell(2,15,0)
    mkEntityFieldDataInstance :: Type -> [Con] -> Dec
    mkEntityFieldDataInstance :: Type -> [Con] -> Dec
    mkEntityFieldDataInstance Type
    genDataType [Con]
    allEntDefs =
            [Type]
    -> Maybe [TyVarBndr ()]
    -> Type
    -> Maybe Type
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataInstD
                []
                Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing
                (Type -> Type -> Type
    AppT (Type -> Type -> Type
    AppT (Name -> Type
    ConT ''EntityField) Type
    genDataType) (Name -> Type
    VarT (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName String
    "typ"))
                Maybe Type
    forall a. Maybe a
    Nothing
                [Con]
    allEntDefs
                []
    #else
    mkEntityFieldDataInstance :: Type -> [Con] -> Dec
    mkEntityFieldDataInstance genDataType allEntDefs =
            DataInstD
                []
                ''EntityField
                [ genDataType
                , VarT $ mkName "typ"
                ]
                Nothing
                allEntDefs
                []
    #endif

    #if MIN_VERSION_template_haskell(2,15,0)
    mkTySynInstanceForBackend :: MkPersistSettings -> Type -> Dec
    mkTySynInstanceForBackend :: MkPersistSettings -> Type -> Dec
    mkTySynInstanceForBackend MkPersistSettings
    mps Type
    genDataType  =
            TySynEqn -> Dec
    TySynInstD
                (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
    TySynEqn
                   Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing
                   (Type -> Type -> Type
    AppT (Name -> Type
    ConT ''PersistEntityBackend) Type
    genDataType)
                   (MkPersistSettings -> Type
    backendDataType MkPersistSettings
    mps))
    #else
    mkTySynInstanceForBackend :: MkPersistSettings -> Type -> Dec
    mkTySynInstanceForBackend mps genDataType  =
            TySynInstD
                ''PersistEntityBackend
                (TySynEqn
                   [genDataType]
                   (backendDataType mps))
    #endif

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

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

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

    -- | @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 Maybe Text
    forall a. Maybe a
    Nothing Text
    "__Composite_Key__"
                , fieldSqlType :: SqlType
    fieldSqlType =
                    Text -> SqlType
    SqlOther Text
    "Composite Key"
                , fieldAttrs :: [FieldAttr]
    fieldAttrs =
                    []
                , fieldStrict :: Bool
    fieldStrict =
                    Bool
    False
                , fieldReference :: ReferenceDef
    fieldReference =
                    ReferenceDef
    NoReference
                , fieldCascade :: FieldCascade
    fieldCascade =
                    FieldCascade
    noCascade
                , fieldComments :: Maybe Text
    fieldComments =
                    Maybe Text
    forall a. Maybe a
    Nothing
                , fieldGenerated :: Maybe Text
    fieldGenerated =
                    Maybe Text
    forall a. Maybe a
    Nothing
                , fieldIsImplicitIdColumn :: Bool
    fieldIsImplicitIdColumn =
                    Bool
    False
                }

    mkFields
        :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
    mkFields :: MkPersistSettings
    -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
    mkFields MkPersistSettings
    mps EntityMap
    entityMap UnboundEntityDef
    entDef =
        EntityFieldTH -> [EntityFieldTH] -> EntityFieldsTH
    EntityFieldsTH
            (EntityFieldTH -> [EntityFieldTH] -> EntityFieldsTH)
    -> Q EntityFieldTH -> Q ([EntityFieldTH] -> EntityFieldsTH)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
    mkIdField MkPersistSettings
    mps UnboundEntityDef
    entDef
            Q ([EntityFieldTH] -> EntityFieldsTH)
    -> Q [EntityFieldTH] -> Q EntityFieldsTH
    forall a b. Q (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> (UnboundFieldDef -> Q EntityFieldTH)
    -> [UnboundFieldDef] -> Q [EntityFieldTH]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (MkPersistSettings
    -> EntityMap
    -> UnboundEntityDef
    -> UnboundFieldDef
    -> Q EntityFieldTH
    mkField MkPersistSettings
    mps EntityMap
    entityMap UnboundEntityDef
    entDef) (UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs UnboundEntityDef
    entDef)

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

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

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

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

        mkOnlyUniqueError :: Q Cxt -> Q [Dec]
        mkOnlyUniqueError :: Q [Type] -> Q [Dec]
    mkOnlyUniqueError Q [Type]
    mkCtx = do
            ctx <- Q [Type]
    mkCtx
            let
                impl = Name -> [Dec]
    mkImpossible Name
    onlyUniquePName
            pure [instanceD ctx onlyOneUniqueKeyClass impl]

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

        typeErrorAtLeastOne :: Q [Dec]
        typeErrorAtLeastOne :: Q [Dec]
    typeErrorAtLeastOne = do
            let
                impl :: [Dec]
    impl = Name -> [Dec]
    mkImpossible Name
    requireUniquesPName
            cxt <- Q [Type]
    typeErrorNoneCtx
            pure [instanceD cxt atLeastOneUniqueKeyClass impl]

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

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

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

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

    entityText :: UnboundEntityDef -> Text
    entityText :: UnboundEntityDef -> Text
    entityText = EntityNameHS -> Text
    unEntityNameHS (EntityNameHS -> Text)
    -> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS

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

    #if MIN_VERSION_template_haskell(2,21,0)
    mkPlainTV
        :: Name
        -> TyVarBndr BndrVis
    mkPlainTV :: Name -> TyVarBndr BndrVis
    mkPlainTV Name
    n = Name -> BndrVis -> TyVarBndr BndrVis
    forall flag. Name -> flag -> TyVarBndr flag
    PlainTV Name
    n BndrVis
    forall flag. DefaultBndrFlag flag => flag
    defaultBndrFlag

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

    mkForallTV :: Name -> TyVarBndr Specificity
    mkForallTV n = PlainTV n SpecifiedSpec
    #else

    mkPlainTV
        :: Name
        -> TyVarBndr
    mkPlainTV = PlainTV

    mkForallTV
        :: Name
        -> TyVarBndr
    mkForallTV = mkPlainTV
    #endif

    mkForeignKeysComposite
        :: MkPersistSettings
        -> UnboundEntityDef
        -> UnboundForeignDef
        -> Q [Dec]
    mkForeignKeysComposite :: MkPersistSettings
    -> UnboundEntityDef -> UnboundForeignDef -> Q [Dec]
    mkForeignKeysComposite MkPersistSettings
    mps UnboundEntityDef
    entDef UnboundForeignDef
    foreignDef
        | ForeignDef -> Bool
    foreignToPrimary (UnboundForeignDef -> ForeignDef
    unboundForeignDef UnboundForeignDef
    foreignDef) = do
            let
                fieldName :: FieldNameHS -> Name
    fieldName =
                    MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
    fieldNameToRecordName MkPersistSettings
    mps UnboundEntityDef
    entDef
                fname :: Name
    fname =
                    FieldNameHS -> Name
    fieldName (FieldNameHS -> Name) -> FieldNameHS -> Name
    forall a b. (a -> b) -> a -> b
    $
                        ConstraintNameHS -> FieldNameHS
    constraintToField (ConstraintNameHS -> FieldNameHS)
    -> ConstraintNameHS -> FieldNameHS
    forall a b. (a -> b) -> a -> b
    $
                            ForeignDef -> ConstraintNameHS
    foreignConstraintNameHaskell (ForeignDef -> ConstraintNameHS) -> ForeignDef -> ConstraintNameHS
    forall a b. (a -> b) -> a -> b
    $
                                UnboundForeignDef -> ForeignDef
    unboundForeignDef UnboundForeignDef
    foreignDef
                reftableString :: String
    reftableString =
                    Text -> String
    unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ EntityNameHS -> Text
    unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
    forall a b. (a -> b) -> a -> b
    $ ForeignDef -> EntityNameHS
    foreignRefTableHaskell (ForeignDef -> EntityNameHS) -> ForeignDef -> EntityNameHS
    forall a b. (a -> b) -> a -> b
    $ UnboundForeignDef -> ForeignDef
    unboundForeignDef UnboundForeignDef
    foreignDef
                reftableKeyName :: Name
    reftableKeyName =
                    String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    reftableString String -> String -> String
    forall m. Monoid m => m -> m -> m
    `mappend` String
    "Key"
                tablename :: Name
    tablename =
                    UnboundEntityDef -> Name
    mkEntityDefName UnboundEntityDef
    entDef
                fieldStore :: FieldStore
    fieldStore =
                    UnboundEntityDef -> FieldStore
    mkFieldStore UnboundEntityDef
    entDef

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

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

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

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

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

            sigTy <- [t|$(conT tablename) -> $(pure keyTargetTable)|]
            pure
                [ SigD fname sigTy
                , fn
                ]
        | Bool
    otherwise =
            [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure []
      where
        constraintToField :: ConstraintNameHS -> FieldNameHS
    constraintToField = Text -> FieldNameHS
    FieldNameHS (Text -> FieldNameHS)
    -> (ConstraintNameHS -> Text) -> ConstraintNameHS -> FieldNameHS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConstraintNameHS -> Text
    unConstraintNameHS

    maybeExp :: Bool -> Exp -> Exp
    maybeExp :: Bool -> Exp -> Exp
    maybeExp Bool
    may Exp
    exp
        | Bool
    may = Exp
    fmapE Exp -> Exp -> Exp
    `AppE` Exp
    exp
        | Bool
    otherwise = Exp
    exp

    maybeTyp :: Bool -> Type -> Type
    maybeTyp :: Bool -> Type -> Type
    maybeTyp Bool
    may Type
    typ
        | Bool
    may = Name -> Type
    ConT ''Maybe Type -> Type -> Type
    `AppT` Type
    typ
        | Bool
    otherwise = Type
    typ

    entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue
    entityToPersistValueHelper :: forall record. PersistEntity record => record -> PersistValue
    entityToPersistValueHelper record
    entity = [(Text, PersistValue)] -> PersistValue
    PersistMap ([(Text, PersistValue)] -> PersistValue)
    -> [(Text, PersistValue)] -> PersistValue
    forall a b. (a -> b) -> a -> b
    $ [Text] -> [PersistValue] -> [(Text, PersistValue)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Text]
    columnNames [PersistValue]
    fieldsAsPersistValues
      where
        columnNames :: [Text]
    columnNames =
            (FieldDef -> Text) -> [FieldDef] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (FieldNameHS -> Text
    unFieldNameHS (FieldNameHS -> Text)
    -> (FieldDef -> FieldNameHS) -> FieldDef -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FieldDef -> FieldNameHS
    fieldHaskell) (EntityDef -> [FieldDef]
    getEntityFields (Maybe record -> EntityDef
    forall record (proxy :: * -> *).
    PersistEntity record =>
    proxy record -> EntityDef
    forall (proxy :: * -> *). proxy record -> EntityDef
    entityDef (record -> Maybe record
    forall a. a -> Maybe a
    Just record
    entity)))
        fieldsAsPersistValues :: [PersistValue]
    fieldsAsPersistValues = (PersistValue -> PersistValue) -> [PersistValue] -> [PersistValue]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap PersistValue -> PersistValue
    forall a. PersistField a => a -> PersistValue
    toPersistValue ([PersistValue] -> [PersistValue])
    -> [PersistValue] -> [PersistValue]
    forall a b. (a -> b) -> a -> b
    $ record -> [PersistValue]
    forall record. PersistEntity record => record -> [PersistValue]
    toPersistFields record
    entity

    entityFromPersistValueHelper
        :: (PersistEntity record)
        => [String]
        -- ^ 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
        (persistMap :: [(T.Text, PersistValue)]) <- PersistValue -> Either Text [(Text, PersistValue)]
    getPersistMap PersistValue
    pv

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

        fromPersistValues $ fmap lookupPersistValueByColumnName columnNames

    -- | 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
        sqlStringConstructor' <- [|SqlString|]
        toPersistValueImplementation <- [|entityToPersistValueHelper|]
        fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|]

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

    -- | 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 = [[Dec]] -> [Dec]
    forall a. Monoid a => [a] -> a
    mconcat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (([a] -> Q [Dec]) -> Q [Dec]) -> [[a] -> Q [Dec]] -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (([a] -> Q [Dec]) -> [a] -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ [a]
    x) [[a] -> Q [Dec]]
    fs

    -- | 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
        edefs <- ([Exp] -> Exp) -> Q [Exp] -> Q Exp
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [Exp] -> Exp
    ListE
            (Q [Exp] -> Q Exp)
    -> ((UnboundEntityDef -> Q Exp) -> Q [Exp])
    -> (UnboundEntityDef -> Q Exp)
    -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [UnboundEntityDef] -> (UnboundEntityDef -> Q Exp) -> Q [Exp]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [UnboundEntityDef]
    entityDefs
            ((UnboundEntityDef -> Q Exp) -> Q Exp)
    -> (UnboundEntityDef -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \UnboundEntityDef
    entDef ->
                let
                    entityType :: Q Type
    entityType = UnboundEntityDef -> Q Type
    entityDefConT UnboundEntityDef
    entDef
                 in
                    [|entityDef (Proxy :: Proxy $(Q Type
    entityType))|]
        typ <- [t|[EntityDef]|]
        pure
            [ SigD entityListName typ
            , ValD (VarP entityListName) (NormalB edefs) []
            ]

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

        go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
        go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
    go [(FieldNameHS, Name)]
    xs (UniqueDef ConstraintNameHS
    name ConstraintNameDB
    _ NonEmpty ForeignFieldDef
    cols [Text]
    _) =
            (Exp -> FieldNameHS -> Exp) -> Exp -> [FieldNameHS] -> Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    List.foldl' ([(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
    go' [(FieldNameHS, Name)]
    xs) (Name -> Exp
    ConE (ConstraintNameHS -> Name
    mkConstraintName ConstraintNameHS
    name)) (NonEmpty FieldNameHS -> [FieldNameHS]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (NonEmpty FieldNameHS -> [FieldNameHS])
    -> NonEmpty FieldNameHS -> [FieldNameHS]
    forall a b. (a -> b) -> a -> b
    $ (ForeignFieldDef -> FieldNameHS)
    -> NonEmpty ForeignFieldDef -> NonEmpty FieldNameHS
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ForeignFieldDef -> FieldNameHS
    forall a b. (a, b) -> a
    fst NonEmpty ForeignFieldDef
    cols)

        go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
        go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
    go' [(FieldNameHS, Name)]
    xs Exp
    front FieldNameHS
    col =
            let
                col' :: Name
    col' =
                    Name -> Maybe Name -> Name
    forall a. a -> Maybe a -> a
    fromMaybe
                        (String -> Name
    forall a. HasCallStack => String -> a
    error (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "failed in go' while looking up col=" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> FieldNameHS -> String
    forall a. Show a => a -> String
    show FieldNameHS
    col)
                        (FieldNameHS -> [(FieldNameHS, Name)] -> Maybe Name
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup FieldNameHS
    col [(FieldNameHS, Name)]
    xs)
             in
                Exp
    front Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    col'

    sqlTypeFunD :: Exp -> Dec
    sqlTypeFunD :: Exp -> Dec
    sqlTypeFunD Exp
    st =
        Name -> [Clause] -> Dec
    FunD
            'sqlType
            [[Pat] -> Exp -> Clause
    normalClause [Pat
    WildP] Exp
    st]

    typeInstanceD
        :: Name
        -> Bool
        -- ^ 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
        ss <- [|SqlString|]
        tpv <- [|PersistText . pack . show|]
        fpv <-
            [|
                \dt v ->
                    case fromPersistValue v of
                        Left e -> Left e
                        Right s' ->
                            case reads $ unpack s' of
                                (x, _) : _ -> Right x
                                [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'
                |]
        return
            [ persistFieldInstanceD
                False
                (ConT $ mkName s)
                [ FunD
                    'toPersistValue
                    [ normalClause [] tpv
                    ]
                , FunD
                    'fromPersistValue
                    [ normalClause [] (fpv `AppE` LitE (StringL s))
                    ]
                ]
            , persistFieldSqlInstanceD
                False
                (ConT $ mkName s)
                [ sqlTypeFunD ss
                ]
            ]

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

    -- | 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 =
        [EntityDef] -> (EntityDef -> Migration) -> Migration
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ ((EntityDef -> Bool) -> [EntityDef] -> [EntityDef]
    forall a. (a -> Bool) -> [a] -> [a]
    filter EntityDef -> Bool
    isMigrated [EntityDef]
    defs) ((EntityDef -> Migration) -> Migration)
    -> (EntityDef -> Migration) -> Migration
    forall a b. (a -> b) -> a -> b
    $ \EntityDef
    def ->
            [EntityDef] -> EntityDef -> Migration
    migrate [EntityDef]
    defs EntityDef
    def
      where
        isMigrated :: EntityDef -> Bool
    isMigrated EntityDef
    def = String -> Text
    pack String
    "no-migrate" Text -> [Text] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` EntityDef -> [Text]
    entityAttrs EntityDef
    def

    -- | 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" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    fun)
        body <- [|migrateModels $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (String -> Name
    mkName String
    entityDefListName))|]
        edList <- mkEntityDefList entityDefListName eds
        pure $
            edList
                <> [ SigD (mkName fun) (ConT ''Migration)
                   , FunD (mkName fun) [normalClause [] body]
                   ]

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

    -- 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 (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName String
    "typ") Type
    fieldT]
                    (Con -> Con) -> Con -> Con
    forall a b. (a -> b) -> a -> b
    $ Name -> [BangType] -> Con
    NormalC Name
    name []
            fieldT :: Type
    fieldT =
                MkPersistSettings
    -> EntityMap
    -> UnboundFieldDef
    -> Maybe Name
    -> Maybe IsNullable
    -> Type
    maybeIdType MkPersistSettings
    mps EntityMap
    entityMap UnboundFieldDef
    fieldDef Maybe Name
    forall a. Maybe a
    Nothing Maybe IsNullable
    forall a. Maybe a
    Nothing
        bod <- UnboundEntityDef -> FieldNameHS -> Q Exp
    mkLookupEntityField UnboundEntityDef
    et (UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    fieldDef)
        let
            cla =
                [Pat] -> Exp -> Clause
    normalClause
                    [Name -> [Pat] -> Pat
    conp Name
    name []]
                    Exp
    bod
        return $ EntityFieldTH con cla
      where
        name :: Name
    name = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
    filterConName MkPersistSettings
    mps UnboundEntityDef
    et UnboundFieldDef
    fieldDef

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

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

    mkLookupEntityField
        :: UnboundEntityDef
        -> FieldNameHS
        -> Q Exp
    mkLookupEntityField :: UnboundEntityDef -> FieldNameHS -> Q Exp
    mkLookupEntityField UnboundEntityDef
    ued FieldNameHS
    ufd =
        [|
            lookupEntityField
                (Proxy :: Proxy $(Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    entityName))
                $(FieldNameHS -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => FieldNameHS -> m Exp
    lift FieldNameHS
    ufd)
            |]
      where
        entityName :: Name
    entityName = EntityNameHS -> Name
    mkEntityNameHSName (UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    ued)

    maybeNullable :: UnboundFieldDef -> Bool
    maybeNullable :: UnboundFieldDef -> Bool
    maybeNullable UnboundFieldDef
    fd = UnboundFieldDef -> IsNullable
    isUnboundFieldNullable UnboundFieldDef
    fd IsNullable -> IsNullable -> Bool
    forall a. Eq a => a -> a -> Bool
    == WhyNullable -> IsNullable
    Nullable WhyNullable
    ByMaybeAttr

    ftToType :: FieldType -> Type
    ftToType :: FieldType -> Type
    ftToType = \case
        FTTypeCon Maybe Text
    Nothing Text
    t ->
            Name -> Type
    ConT (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack Text
    t
        -- 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 (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ [Text] -> Text
    concat [Text
    m, Text
    ".", Text
    t]
        FTLit FieldTypeLit
    l ->
            TyLit -> Type
    LitT (FieldTypeLit -> TyLit
    typeLitToTyLit FieldTypeLit
    l)
        FTTypePromoted Text
    t ->
            Name -> Type
    PromotedT (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack Text
    t
        FTApp FieldType
    x FieldType
    y ->
            FieldType -> Type
    ftToType FieldType
    x Type -> Type -> Type
    `AppT` FieldType -> Type
    ftToType FieldType
    y
        FTList FieldType
    x ->
            Type
    ListT Type -> Type -> Type
    `AppT` FieldType -> Type
    ftToType FieldType
    x

    typeLitToTyLit :: FieldTypeLit -> TyLit
    typeLitToTyLit :: FieldTypeLit -> TyLit
    typeLitToTyLit = \case
        IntTypeLit Integer
    n -> Integer -> TyLit
    NumTyLit Integer
    n
        TextTypeLit Text
    t -> String -> TyLit
    StrTyLit (Text -> String
    T.unpack Text
    t)

    infixr 5 ++
    (++) :: (Monoid m) => m -> m -> m
    ++ :: forall m. Monoid m => m -> m -> m
    (++) = m -> m -> m
    forall m. Monoid m => m -> m -> m
    mappend

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

        let
            objectE = Name -> Exp
    VarE 'object
            withObjectE = Name -> Exp
    VarE 'withObject
            dotEqualE = Name -> Exp
    VarE '(.=)
            dotColonE = Name -> Exp
    VarE '(.:)
            dotColonQE = Name -> Exp
    VarE '(.:?)
            toKeyE = Exp
    aesonKeyFromString
        obj <- newName "obj"
        let
            fields =
                UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs UnboundEntityDef
    def

        xs <- mapM fieldToJSONValName fields

        let
            conName =
                UnboundEntityDef -> Name
    mkEntityDefName UnboundEntityDef
    def
            typ =
                MkPersistSettings -> EntityNameHS -> Type -> Type
    genericDataType MkPersistSettings
    mps (EntityDef -> EntityNameHS
    entityHaskell (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    def)) Type
    backendT
            toJSONI =
                Name -> Bool -> Type -> [Dec] -> Dec
    typeInstanceD ''ToJSON (MkPersistSettings -> Bool
    mpsGeneric MkPersistSettings
    mps) Type
    typ [Dec
    toJSON']
              where
                toJSON' :: Dec
    toJSON' =
                    Name -> [Clause] -> Dec
    FunD 'toJSON ([Clause] -> Dec) -> [Clause] -> Dec
    forall a b. (a -> b) -> a -> b
    $
                        Clause -> [Clause]
    forall a. a -> [a]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Clause -> [Clause]) -> Clause -> [Clause]
    forall a b. (a -> b) -> a -> b
    $
                            [Pat] -> Exp -> Clause
    normalClause
                                [Name -> [Pat] -> Pat
    conp Name
    conName ([Pat] -> Pat) -> [Pat] -> Pat
    forall a b. (a -> b) -> a -> b
    $ (Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Pat
    VarP [Name]
    xs]
                                (Exp
    objectE Exp -> Exp -> Exp
    `AppE` [Exp] -> Exp
    ListE [Exp]
    pairs)
                  where
                    pairs :: [Exp]
    pairs = (UnboundFieldDef -> Name -> Exp)
    -> [UnboundFieldDef] -> [Name] -> [Exp]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith UnboundFieldDef -> Name -> Exp
    toPair [UnboundFieldDef]
    fields [Name]
    xs
                    toPair :: UnboundFieldDef -> Name -> Exp
    toPair UnboundFieldDef
    f Name
    x =
                        Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE
                            ( Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just
                                (Exp
    toKeyE Exp -> Exp -> Exp
    `AppE` Lit -> Exp
    LitE (String -> Lit
    StringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ FieldNameHS -> Text
    unFieldNameHS (FieldNameHS -> Text) -> FieldNameHS -> Text
    forall a b. (a -> b) -> a -> b
    $ UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    f))
                            )
                            Exp
    dotEqualE
                            (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    x)
            fromJSONI =
                Name -> Bool -> Type -> [Dec] -> Dec
    typeInstanceD ''FromJSON (MkPersistSettings -> Bool
    mpsGeneric MkPersistSettings
    mps) Type
    typ [Dec
    parseJSON']
              where
                entNameStrLit :: Lit
    entNameStrLit =
                    String -> Lit
    StringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack (EntityNameHS -> Text
    unEntityNameHS (UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    def))
                parseJSONBody :: Exp
    parseJSONBody =
                    Exp
    withObjectE Exp -> Exp -> Exp
    `AppE` Lit -> Exp
    LitE Lit
    entNameStrLit Exp -> Exp -> Exp
    `AppE` Exp
    decoderImpl
                parseJSON' :: Dec
    parseJSON' =
                    Name -> [Clause] -> Dec
    FunD 'parseJSON [[Pat] -> Exp -> Clause
    normalClause [] Exp
    parseJSONBody]
                decoderImpl :: Exp
    decoderImpl =
                    [Pat] -> Exp -> Exp
    LamE
                        [Name -> Pat
    VarP Name
    obj]
                        ( (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    List.foldl'
                            (\Exp
    x Exp
    y -> Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    x) Exp
    apE' (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    y))
                            (Exp
    pureE Exp -> Exp -> Exp
    `AppE` Name -> Exp
    ConE Name
    conName)
                            [Exp]
    pulls
                        )
                  where
                    pulls :: [Exp]
    pulls =
                        (UnboundFieldDef -> Exp) -> [UnboundFieldDef] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap UnboundFieldDef -> Exp
    toPull [UnboundFieldDef]
    fields
                    toPull :: UnboundFieldDef -> Exp
    toPull UnboundFieldDef
    f =
                        Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE
                            (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    obj)
                            (if UnboundFieldDef -> Bool
    maybeNullable UnboundFieldDef
    f then Exp
    dotColonQE else Exp
    dotColonE)
                            ( Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
    forall a b. (a -> b) -> a -> b
    $
                                Exp -> Exp -> Exp
    AppE Exp
    toKeyE (Exp -> Exp) -> Exp -> Exp
    forall a b. (a -> b) -> a -> b
    $
                                    Lit -> Exp
    LitE (Lit -> Exp) -> Lit -> Exp
    forall a b. (a -> b) -> a -> b
    $
                                        String -> Lit
    StringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $
                                            Text -> String
    unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $
                                                FieldNameHS -> Text
    unFieldNameHS (FieldNameHS -> Text) -> FieldNameHS -> Text
    forall a b. (a -> b) -> a -> b
    $
                                                    UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    f
                            )

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

                                instance (PersistStore $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    backendT)) => FromJSON (Entity $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    typ)) where
                                    parseJSON = $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (EntityJSON -> Name
    entityFromJSON EntityJSON
    entityJSON))
                                |]
                        else
                            [d|
                                instance ToJSON (Entity $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    typ)) where
                                    toJSON = $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (EntityJSON -> Name
    entityToJSON EntityJSON
    entityJSON))

                                instance FromJSON (Entity $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    typ)) where
                                    parseJSON = $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (EntityJSON -> Name
    entityFromJSON EntityJSON
    entityJSON))
                                |]
                return $ toJSONI : fromJSONI : entityJSONIs

    #if MIN_VERSION_aeson(2,0,0)
    aesonKeyFromString :: Exp
    aesonKeyFromString :: Exp
    aesonKeyFromString =
            Name -> Exp
    VarE 'Key.fromString
    #else
    aesonKeyFromString :: Exp
    aesonKeyFromString =
            VarE 'pack
    #endif

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

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

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

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

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

    -- | 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 =
            (Extension -> [Extension]) -> [Extension] -> [[Extension]]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap
                Extension -> [Extension]
    forall a. a -> [a]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
                [ Extension
    DerivingStrategies
                , Extension
    GeneralizedNewtypeDeriving
                , Extension
    StandaloneDeriving
                , Extension
    UndecidableInstances
                , Extension
    MultiParamTypeClasses
                ]

    mkSymbolToFieldInstances
        :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
    mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
    mkSymbolToFieldInstances MkPersistSettings
    mps EntityMap
    entityMap (UnboundEntityDef -> UnboundEntityDef
    fixEntityDef -> UnboundEntityDef
    ed) = do
        let
            entityHaskellName :: EntityNameHS
    entityHaskellName =
                EntityDef -> EntityNameHS
    getEntityHaskellName (EntityDef -> EntityNameHS) -> EntityDef -> EntityNameHS
    forall a b. (a -> b) -> a -> b
    $ UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    ed
            allFields :: [UnboundFieldDef]
    allFields =
                UnboundEntityDef -> [UnboundFieldDef]
    getUnboundFieldDefs UnboundEntityDef
    ed
            mkEntityFieldConstr :: FieldNameHS -> Q Exp
    mkEntityFieldConstr FieldNameHS
    fieldHaskellName =
                Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE (Name -> Q Exp) -> Name -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
    filterConName' MkPersistSettings
    mps EntityNameHS
    entityHaskellName FieldNameHS
    fieldHaskellName
                    :: Q Exp
        regularFields <- [UnboundFieldDef] -> (UnboundFieldDef -> Q [Dec]) -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM ([UnboundFieldDef] -> [UnboundFieldDef]
    forall a. [a] -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList [UnboundFieldDef]
    allFields) ((UnboundFieldDef -> Q [Dec]) -> Q [[Dec]])
    -> (UnboundFieldDef -> Q [Dec]) -> Q [[Dec]]
    forall a b. (a -> b) -> a -> b
    $ \UnboundFieldDef
    fieldDef -> do
            let
                fieldHaskellName :: FieldNameHS
    fieldHaskellName =
                    UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    fieldDef

            let
                fieldNameT :: Q Type
                fieldNameT :: Q Type
    fieldNameT =
                    Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
    forall a b. (a -> b) -> a -> b
    $
                        String -> Q TyLit
    forall (m :: * -> *). Quote m => String -> m TyLit
    strTyLit (String -> Q TyLit) -> String -> Q TyLit
    forall a b. (a -> b) -> a -> b
    $
                            Text -> String
    T.unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $
                                Text -> Text
    forall {a}. (Eq a, IsString a) => a -> a
    lowerFirstIfId (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $
                                    FieldNameHS -> Text
    unFieldNameHS FieldNameHS
    fieldHaskellName

                lowerFirstIfId :: a -> a
    lowerFirstIfId a
    "Id" = a
    "id"
                lowerFirstIfId a
    xs = a
    xs

                fieldTypeT :: Q Type
    fieldTypeT
                    | FieldNameHS
    fieldHaskellName FieldNameHS -> FieldNameHS -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text -> FieldNameHS
    FieldNameHS Text
    "Id" =
                        Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT ''Key Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    recordNameT
                    | Bool
    otherwise =
                        Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Type -> Q Type) -> Type -> Q Type
    forall a b. (a -> b) -> a -> b
    $ MkPersistSettings
    -> EntityMap
    -> UnboundFieldDef
    -> Maybe Name
    -> Maybe IsNullable
    -> Type
    maybeIdType MkPersistSettings
    mps EntityMap
    entityMap UnboundFieldDef
    fieldDef Maybe Name
    forall a. Maybe a
    Nothing Maybe IsNullable
    forall a. Maybe a
    Nothing
                entityFieldConstr :: Q Exp
    entityFieldConstr =
                    FieldNameHS -> Q Exp
    mkEntityFieldConstr FieldNameHS
    fieldHaskellName
            Q Type -> Q Type -> Q Exp -> Q [Dec]
    mkInstance Q Type
    fieldNameT Q Type
    fieldTypeT Q Exp
    entityFieldConstr

        mkey <- do
            let
                fieldHaskellName =
                    Text -> FieldNameHS
    FieldNameHS Text
    "Id"
                entityFieldConstr =
                    FieldNameHS -> Q Exp
    mkEntityFieldConstr FieldNameHS
    fieldHaskellName
                fieldTypeT =
                    Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT ''Key Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    recordNameT
            mkInstance [t|"id"|] fieldTypeT entityFieldConstr

        pure (mkey <> join regularFields)
      where
        nameG :: Name
    nameG =
            UnboundEntityDef -> Name
    mkEntityDefGenericName UnboundEntityDef
    ed
        recordNameT :: Q Type
    recordNameT
            | MkPersistSettings -> Bool
    mpsGeneric MkPersistSettings
    mps =
                Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    nameG Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT Name
    backendName
            | Bool
    otherwise =
                UnboundEntityDef -> Q Type
    entityDefConT UnboundEntityDef
    ed
        mkInstance :: Q Type -> Q Type -> Q Exp -> Q [Dec]
    mkInstance Q Type
    fieldNameT Q Type
    fieldTypeT Q Exp
    entityFieldConstr =
            [d|
                instance SymbolToField $(Q Type
    fieldNameT) $(Q Type
    recordNameT) $(Q Type
    fieldTypeT) where
                    symbolToField = $(Q Exp
    entityFieldConstr)
                |]

    -- | 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)
        unenabledExtensions <-
            ([Extension] -> Q Bool) -> [[Extension]] -> Q [[Extension]]
    forall (m :: * -> *) a.
    Applicative m =>
    (a -> m Bool) -> [a] -> m [a]
    filterM (([Bool] -> Bool) -> Q [Bool] -> Q Bool
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Bool -> Bool
    not (Bool -> Bool) -> ([Bool] -> Bool) -> [Bool] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or) (Q [Bool] -> Q Bool)
    -> ([Extension] -> Q [Bool]) -> [Extension] -> Q Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Extension -> Q Bool) -> [Extension] -> Q [Bool]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse Extension -> Q Bool
    isExtEnabled) [[Extension]]
    requiredExtensions

        case mapMaybe listToMaybe unenabledExtensions of
            [] -> () -> Q ()
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
            [Extension
    extension] ->
                String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $
                    [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                        [ String
    "Generating Persistent entities now requires the "
                        , Extension -> String
    forall a. Show a => a -> String
    show Extension
    extension
                        , String
    " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n"
                        , Extension -> String
    forall a. Show a => a -> String
    extensionToPragma Extension
    extension
                        ]
            [Extension]
    extensions ->
                String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $
                    [String] -> String
    forall a. Monoid a => [a] -> a
    mconcat
                        [ String
    "Generating Persistent entities now requires the following language extensions:\n\n"
                        , String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    List.intercalate String
    "\n" ((Extension -> String) -> [Extension] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Extension -> String
    forall a. Show a => a -> String
    show [Extension]
    extensions)
                        , String
    "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"
                        , String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    List.intercalate String
    "\n" ((Extension -> String) -> [Extension] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Extension -> String
    forall a. Show a => a -> String
    extensionToPragma [Extension]
    extensions)
                        ]
      where
        extensionToPragma :: a -> String
    extensionToPragma a
    ext = String
    "{-# LANGUAGE " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> a -> String
    forall a. Show a => a -> String
    show a
    ext String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    " #-}"

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

    -- | 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 (Text -> Text) -> (FieldNameHS -> Text) -> FieldNameHS -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FieldNameHS -> Text
    unFieldNameHS
      where
        fixTypeUnderscore :: Text -> Text
    fixTypeUnderscore = \case
            Text
    "type" -> Text
    "type_"
            Text
    name -> Text
    name

    entityDefConK :: UnboundEntityDef -> Kind
    entityDefConK :: UnboundEntityDef -> Type
    entityDefConK = Name -> Type
    conK (Name -> Type)
    -> (UnboundEntityDef -> Name) -> UnboundEntityDef -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundEntityDef -> Name
    mkEntityDefName

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

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

    -- | 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 = Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "_"
            | Bool
    otherwise = Maybe Text
    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
            Maybe Text
    forall a. Maybe a
    Nothing
            (EntityDef -> EntityNameHS
    entityHaskell (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    entDef))
            (UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    fieldDef)

    mkRecordName
        :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
    mkRecordName :: MkPersistSettings
    -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
    mkRecordName MkPersistSettings
    mps Maybe Text
    prefix EntityNameHS
    entNameHS FieldNameHS
    fieldNameHS =
        String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    avoidKeyword (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    "" Maybe Text
    prefix Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    lowerFirst Text
    recName
      where
        recName :: Text
        recName :: Text
    recName
            | MkPersistSettings -> Bool
    mpsPrefixFields MkPersistSettings
    mps =
                MkPersistSettings -> Text -> Text -> Text
    mpsFieldLabelModifier MkPersistSettings
    mps Text
    entityNameText (Text -> Text
    upperFirst Text
    fieldNameText)
            | Bool
    otherwise = Text
    fieldNameText

        entityNameText :: Text
        entityNameText :: Text
    entityNameText =
            EntityNameHS -> Text
    unEntityNameHS EntityNameHS
    entNameHS

        fieldNameText :: Text
        fieldNameText :: Text
    fieldNameText =
            FieldNameHS -> Text
    unFieldNameHS FieldNameHS
    fieldNameHS

        avoidKeyword :: Text -> Text
        avoidKeyword :: Text -> Text
    avoidKeyword Text
    name =
            if Text
    name Text -> Set Text -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.member` Set Text
    haskellKeywords then MkPersistSettings -> Text -> Text
    mpsAvoidHsKeyword MkPersistSettings
    mps Text
    name else Text
    name

    haskellKeywords :: Set.Set Text
    haskellKeywords :: Set Text
    haskellKeywords =
        [Text] -> Set Text
    forall a. Ord a => [a] -> Set a
    Set.fromList
            [ Text
    "case"
            , Text
    "class"
            , Text
    "data"
            , Text
    "default"
            , Text
    "deriving"
            , Text
    "do"
            , Text
    "else"
            , Text
    "if"
            , Text
    "import"
            , Text
    "in"
            , Text
    "infix"
            , Text
    "infixl"
            , Text
    "infixr"
            , Text
    "instance"
            , Text
    "let"
            , Text
    "module"
            , Text
    "newtype"
            , Text
    "of"
            , Text
    "then"
            , Text
    "type"
            , Text
    "where"
            , Text
    "_"
            , Text
    "foreign"
            ]

    -- | 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 (String -> Name) -> (Text -> String) -> Text -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> String
    T.unpack (Text -> Name) -> [Text] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> EntityDef -> [Text]
    entityDerives (UnboundEntityDef -> EntityDef
    unboundEntityDef UnboundEntityDef
    entDef)
            additionalInstances :: [Name]
    additionalInstances =
                (Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [Name]
    entityInstances) ([Name] -> [Name]) -> [Name] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ MkPersistSettings -> [Name]
    mpsDeriveInstances MkPersistSettings
    mps
         in
            [Name]
    entityInstances [Name] -> [Name] -> [Name]
    forall a. Semigroup a => a -> a -> a
    <> [Name]
    additionalInstances

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

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

    -- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric
    mkEntityDefGenericName :: UnboundEntityDef -> Name
    mkEntityDefGenericName :: UnboundEntityDef -> Name
    mkEntityDefGenericName =
        EntityNameHS -> Name
    mkEntityNameHSGenericName (EntityNameHS -> Name)
    -> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . EntityDef -> EntityNameHS
    entityHaskell (EntityDef -> EntityNameHS)
    -> (UnboundEntityDef -> EntityDef)
    -> UnboundEntityDef
    -> EntityNameHS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundEntityDef -> EntityDef
    unboundEntityDef

    mkEntityNameHSGenericName :: EntityNameHS -> Name
    mkEntityNameHSGenericName :: EntityNameHS -> Name
    mkEntityNameHSGenericName EntityNameHS
    name =
        String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack (EntityNameHS -> Text
    unEntityNameHS EntityNameHS
    name Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "Generic")

    -- 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 (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack Text
    name
      where
        name :: Text
    name
            | MkPersistSettings -> Bool
    mpsPrefixFields MkPersistSettings
    mps = Text
    modifiedName Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    "Sum"
            | Bool
    otherwise = Text
    fieldName Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    "Sum"
        fieldNameHS :: FieldNameHS
    fieldNameHS =
            UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    unboundFieldDef
        modifiedName :: Text
    modifiedName =
            MkPersistSettings -> Text -> Text -> Text
    mpsConstraintLabelModifier MkPersistSettings
    mps Text
    entityName Text
    fieldName
        entityName :: Text
    entityName =
            EntityNameHS -> Text
    unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
    forall a b. (a -> b) -> a -> b
    $ UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    entDef
        fieldName :: Text
    fieldName =
            Text -> Text
    upperFirst (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ FieldNameHS -> Text
    unFieldNameHS FieldNameHS
    fieldNameHS

    -- | 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 (String -> Name)
    -> (UnboundEntityDef -> String) -> UnboundEntityDef -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> String
    T.unpack (Text -> String)
    -> (UnboundEntityDef -> Text) -> UnboundEntityDef -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnboundEntityDef -> Text
    keyIdText

    keyIdText :: UnboundEntityDef -> Text
    keyIdText :: UnboundEntityDef -> Text
    keyIdText UnboundEntityDef
    entDef = EntityNameHS -> Text
    unEntityNameHS (UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    entDef) Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    `mappend` Text
    "Id"

    unKeyName :: UnboundEntityDef -> Name
    unKeyName :: UnboundEntityDef -> Name
    unKeyName UnboundEntityDef
    entDef = String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ Text
    "un" Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    `mappend` UnboundEntityDef -> Text
    keyText UnboundEntityDef
    entDef

    unKeyExp :: UnboundEntityDef -> Exp
    unKeyExp :: UnboundEntityDef -> Exp
    unKeyExp UnboundEntityDef
    ent = Name -> Name -> Exp
    fieldSel (UnboundEntityDef -> Name
    keyConName UnboundEntityDef
    ent) (UnboundEntityDef -> Name
    unKeyName UnboundEntityDef
    ent)

    backendT :: Type
    backendT :: Type
    backendT = Name -> Type
    VarT Name
    backendName

    backendName :: Name
    backendName :: Name
    backendName = String -> Name
    mkName String
    "backend"

    -- 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 (UnboundFieldDef -> FieldNameHS)
    -> [UnboundFieldDef] -> [FieldNameHS]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnboundEntityDef -> [UnboundFieldDef]
    unboundEntityFields (UnboundEntityDef
    entDef))

    keyConName' :: EntityNameHS -> [FieldNameHS] -> Name
    keyConName' :: EntityNameHS -> [FieldNameHS] -> Name
    keyConName' EntityNameHS
    entName [FieldNameHS]
    entFields = String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ Text -> Text
    resolveConflict (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ EntityNameHS -> Text
    keyText' EntityNameHS
    entName
      where
        resolveConflict :: Text -> Text
    resolveConflict Text
    kn = if Bool
    conflict then Text
    kn Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    `mappend` Text
    "'" else Text
    kn
        conflict :: Bool
    conflict = (FieldNameHS -> Bool) -> [FieldNameHS] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (FieldNameHS -> FieldNameHS -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text -> FieldNameHS
    FieldNameHS Text
    "key") [FieldNameHS]
    entFields

    -- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp
    keyConExp :: UnboundEntityDef -> Exp
    keyConExp :: UnboundEntityDef -> Exp
    keyConExp UnboundEntityDef
    ed = Name -> Exp
    ConE (Name -> Exp) -> Name -> Exp
    forall a b. (a -> b) -> a -> b
    $ UnboundEntityDef -> Name
    keyConName UnboundEntityDef
    ed

    keyText :: UnboundEntityDef -> Text
    keyText :: UnboundEntityDef -> Text
    keyText UnboundEntityDef
    entDef = EntityNameHS -> Text
    unEntityNameHS (UnboundEntityDef -> EntityNameHS
    getUnboundEntityNameHS UnboundEntityDef
    entDef) Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    "Key"

    keyText' :: EntityNameHS -> Text
    keyText' :: EntityNameHS -> Text
    keyText' EntityNameHS
    entName = EntityNameHS -> Text
    unEntityNameHS EntityNameHS
    entName Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    "Key"

    keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
    keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
    keyFieldName MkPersistSettings
    mps UnboundEntityDef
    entDef FieldNameHS
    fieldDef
        | MkPersistSettings -> UnboundEntityDef -> Bool
    pkNewtype MkPersistSettings
    mps UnboundEntityDef
    entDef =
            UnboundEntityDef -> Name
    unKeyName UnboundEntityDef
    entDef
        | Bool
    otherwise =
            String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ Text -> Text
    lowerFirst (UnboundEntityDef -> Text
    keyText UnboundEntityDef
    entDef) Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    `mappend` Text
    fieldName
      where
        fieldName :: Text
    fieldName = Text -> Text
    modifyFieldName (FieldNameHS -> Text
    unFieldNameHS FieldNameHS
    fieldDef)
        modifyFieldName :: Text -> Text
    modifyFieldName =
            if MkPersistSettings -> Bool
    mpsCamelCaseCompositeKeySelector MkPersistSettings
    mps then Text -> Text
    upperFirst else Text -> Text
    forall a. a -> a
    id

    filterConName
        :: MkPersistSettings
        -> UnboundEntityDef
        -> UnboundFieldDef
        -> Name
    filterConName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
    filterConName MkPersistSettings
    mps (UnboundEntityDef -> EntityDef
    unboundEntityDef -> EntityDef
    entity) UnboundFieldDef
    field =
        MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
    filterConName' MkPersistSettings
    mps (EntityDef -> EntityNameHS
    entityHaskell EntityDef
    entity) (UnboundFieldDef -> FieldNameHS
    unboundFieldNameHS UnboundFieldDef
    field)

    filterConName'
        :: MkPersistSettings
        -> EntityNameHS
        -> FieldNameHS
        -> Name
    filterConName' :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
    filterConName' MkPersistSettings
    mps EntityNameHS
    entity FieldNameHS
    field = String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    T.unpack Text
    name
      where
        name :: Text
    name
            | FieldNameHS
    field FieldNameHS -> FieldNameHS -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text -> FieldNameHS
    FieldNameHS Text
    "Id" = Text
    entityName Text -> Text -> Text
    forall m. Monoid m => m -> m -> m
    ++ Text
    fieldName
            | MkPersistSettings -> Bool
    mpsPrefixFields MkPersistSettings
    mps = Text
    modifiedName
            | Bool
    otherwise = Text
    fieldName

        modifiedName :: Text
    modifiedName = MkPersistSettings -> Text -> Text -> Text
    mpsConstraintLabelModifier MkPersistSettings
    mps Text
    entityName Text
    fieldName
        entityName :: Text
    entityName = EntityNameHS -> Text
    unEntityNameHS EntityNameHS
    entity
        fieldName :: Text
    fieldName = Text -> Text
    upperFirst (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ FieldNameHS -> Text
    unFieldNameHS FieldNameHS
    field

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

        fmap ListE $
            forM types $ \Type
    typ -> do
                [e|entityDef (Proxy :: Proxy $(Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    typ))|]

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