TH.hs

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

-- | This module provides the tools for defining your database schema and using
-- it to generate Haskell data types and migrations.
--
-- For documentation on the domain specific language used for defining database
-- models, see "Database.Persist.Quasi".
--
--
module Database.Persist.TH
    ( -- * Parse entity defs
      persistWith
    , persistUpperCase
    , persistLowerCase
    , persistFileWith
    , persistManyFileWith
      -- * Turn @EntityDef@s into types
    , mkPersist
    , mkPersistWith
      -- ** Configuring Entity Definition
    , MkPersistSettings
    , mkPersistSettings
    , sqlSettings
    -- *** Record Fields (for update/viewing settings)
    , mpsBackend
    , mpsGeneric
    , mpsPrefixFields
    , mpsFieldLabelModifier
    , 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
       , (.:)
       , (.:?)
       , (.=)
       )
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Key
#endif
import qualified Data.ByteString as BS
import Data.Char (toLower, toUpper)
import Data.Coerce
import Data.Data (Data)
import Data.Either
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.Ix (Ix)
import Data.List (foldl')
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import GHC.TypeLits
import Instances.TH.Lift ()
    -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text`
    -- instance on pre-1.2.4 versions of `text`
import Data.Foldable (asum, toList)
import qualified Data.Set as Set
import Language.Haskell.TH.Lib
       (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT)
#if MIN_VERSION_template_haskell(2,21,0)
import Language.Haskell.TH.Lib (defaultBndrFlag)
#endif
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
import Web.PathPieces (PathPiece(..))

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

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

#if MIN_VERSION_template_haskell(2,18,0)
conp :: Name -> [Pat] -> Pat
conp name pats = ConP name [] 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 ps = QuasiQuoter
    { quoteExp =
        parseReferences ps . pack
    , quotePat =
        error "persistWith can't be used as pattern"
    , quoteType =
        error "persistWith can't be used as type"
    , quoteDec =
        error "persistWith can't be used as declaration"
    }

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

-- | Apply 'persistWith' to 'lowerCaseSettings'.
persistLowerCase :: QuasiQuoter
persistLowerCase = persistWith 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 ps fp = persistManyFileWith ps [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 ps fps = do
    mapM_ qAddDependentFile fps
    ss <- mapM (qRunIO . getFileContents) fps
    let s = T.intercalate "\n" ss -- be tolerant of the user forgetting to put a line-break at EOF.
    parseReferences ps s

getFileContents :: FilePath -> IO Text
getFileContents = fmap decodeUtf8 . 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 eds = snd . embedEntityDefsMap 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 existingEnts rawEnts =
    (embedEntityMap, noCycleEnts)
  where
    noCycleEnts = entsWithEmbeds
    embedEntityMap = constructEmbedEntityMap entsWithEmbeds
    entsWithEmbeds = fmap setEmbedEntity (rawEnts <> map unbindEntityDef existingEnts)
    setEmbedEntity ubEnt =
        let
            ent = unboundEntityDef ubEnt
        in
            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.5.3
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences ps s = lift $ parse ps s

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

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

            fieldStore =
                mkFieldStore unboundEnt
            parentFieldStore =
                mkFieldStore parentDef
            findDBName store fieldNameHS =
                case getFieldDBName fieldNameHS store of
                    Nothing ->
                        error $ mconcat
                            [ "findDBName: failed to fix dbname for: "
                            , show fieldNameHS
                            ]
                    Just a->
                        a

    combinedFixFieldDef :: UnboundFieldDef -> Q Exp
    combinedFixFieldDef ufd@UnboundFieldDef{..} =
        [|
        FieldDef
            { fieldHaskell =
                unboundFieldNameHS
            , fieldDB =
                unboundFieldNameDB
            , fieldType =
                unboundFieldType
            , fieldSqlType =
                $(sqlTyp')
            , fieldAttrs =
                unboundFieldAttrs
            , fieldStrict =
                unboundFieldStrict
            , fieldReference =
                $(fieldRef')
            , fieldCascade =
                unboundFieldCascade
            , fieldComments =
                unboundFieldComments
            , fieldGenerated =
                unboundFieldGenerated
            , fieldIsImplicitIdColumn =
                False
            }
        |]
      where
        sqlTypeExp =
            getSqlType emEntities entityMap ufd
        FieldDef _x _ _ _ _ _ _ _ _ _ _ =
            error "need to update this record wildcard match"
        (fieldRef', sqlTyp') =
            case extractForeignRef entityMap ufd of
                Just targetTable ->
                    let targetTableQualified =
                          fromMaybe targetTable (guessFieldReferenceQualified ufd)
                     in (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTableQualified))
                Nothing ->
                    (lift NoReference, liftSqlTypeExp sqlTypeExp)

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

mkFieldStore :: UnboundEntityDef -> FieldStore
mkFieldStore ued =
    FieldStore
        { fieldStoreEntity = ued
        , fieldStoreMap =
            M.fromList
                $ fmap (\ufd ->
                    ( unboundFieldNameHS ufd
                    , ufd
                    )
                )
                $ getUnboundFieldDefs
                $ ued
        , fieldStoreId =
            case unboundPrimarySpec ued of
                NaturalKey _ ->
                    Nothing
                SurrogateKey fd ->
                    Just $ unboundIdDBName fd
                DefaultKey n ->
                    Just n
        }

getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB
getFieldDBName name fs
    | FieldNameHS "Id" == name =
        fieldStoreId fs
    | otherwise =
        unboundFieldNameDB <$> getFieldDef name fs

getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef fieldNameHS fs =
    M.lookup fieldNameHS (fieldStoreMap fs)

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

guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference = guessReference . unboundFieldType

guessReference :: FieldType -> Maybe EntityNameHS
guessReference ft =
    EntityNameHS <$> guessReferenceText (Just ft)
  where
    checkIdSuffix =
        T.stripSuffix "Id"
    guessReferenceText mft =
        asum
            [ do
                FTTypeCon _ (checkIdSuffix -> Just tableName) <- mft
                pure tableName
            , do
                FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- mft
                pure tableName
            , do
                FTApp (FTTypeCon _ "Maybe") next <- mft
                guessReferenceText (Just next)
            ]

guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS
guessFieldReferenceQualified = guessReferenceQualified . unboundFieldType

guessReferenceQualified :: FieldType -> Maybe EntityNameHS
guessReferenceQualified ft =
    EntityNameHS <$> guessReferenceText (Just ft)
  where
    checkIdSuffix =
        T.stripSuffix "Id"
    guessReferenceText mft =
        asum
            [ do
                FTTypeCon mmod (checkIdSuffix -> Just tableName) <- mft
                -- handle qualified name.
                pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod
            , do
                FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- mft
                -- handle qualified name.
                pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod
            , do
                FTApp (FTTypeCon _ "Maybe") next <- mft
                guessReferenceText (Just next)
            ]

mkDefaultKey
    :: MkPersistSettings
    -> FieldNameDB
    -> EntityNameHS
    -> FieldDef
mkDefaultKey mps  pk unboundHaskellName =
    let
        iid =
            mpsImplicitIdDef mps
    in
        maybe id addFieldAttr (FieldAttrDefault <$> iidDefault iid) $
        maybe id addFieldAttr (FieldAttrMaxlen <$> iidMaxLen iid) $
        mkAutoIdField' pk unboundHaskellName (iidFieldSqlType iid)

fixPrimarySpec
    :: MkPersistSettings
    -> UnboundEntityDef
    -> Q Exp
fixPrimarySpec mps unboundEnt= do
    case unboundPrimarySpec unboundEnt of
        DefaultKey pk ->
            lift $ EntityIdField $
                mkDefaultKey mps pk unboundHaskellName
        SurrogateKey uid -> do
            let
                entNameHS =
                    getUnboundEntityNameHS unboundEnt
                fieldTyp =
                    fromMaybe (mkKeyConType entNameHS) (unboundIdType uid)
            [|
                EntityIdField
                    FieldDef
                        { fieldHaskell =
                            FieldNameHS "Id"
                        , fieldDB =
                            $(lift $ getSqlNameOr (unboundIdDBName uid) (unboundIdAttrs uid))
                        , fieldType =
                            $(lift fieldTyp)
                        , fieldSqlType =
                            $( liftSqlTypeExp (SqlTypeExp  fieldTyp) )
                        , fieldStrict =
                            False
                        , fieldReference =
                            ForeignRef entNameHS
                        , fieldAttrs =
                            unboundIdAttrs uid
                        , fieldComments =
                            Nothing
                        , fieldCascade = unboundIdCascade uid
                        , fieldGenerated = Nothing
                        , fieldIsImplicitIdColumn = True
                        }

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

bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
bindCompositeDef ued ucd = do
    fieldDefs <-
       fmap ListE $ forM (toList $ unboundCompositeCols ucd) $ \col ->
           mkLookupEntityField ued col
    [|
        CompositeDef
            { compositeFields =
                NEL.fromList $(pure fieldDefs)
            , compositeAttrs =
                $(lift $ unboundCompositeAttrs ucd)
            }
        |]

getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
getSqlType emEntities entityMap field =
    maybe
        (defaultSqlTypeExp emEntities entityMap field)
        (SqlType' . SqlOther)
        (listToMaybe $ mapMaybe attrSqlType $ unboundFieldAttrs 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 emEntities entityMap field =
    case mEmbedded emEntities ftype of
        Right _ ->
            SqlType' SqlString
        Left (Just (FTKeyCon ty)) ->
            SqlTypeExp (FTTypeCon Nothing ty)
        Left Nothing ->
            case extractForeignRef entityMap field of
                Just refName ->
                    case M.lookup refName entityMap of
                        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)
                            SqlTypeExp ftype
                        -- A ForeignRef is blindly set to an Int64 in setEmbedField
                        -- correct that now
                        Just _ ->
                            SqlTypeReference refName
                _ ->
                    case 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 _ ->
                            SqlType' SqlString
                        _ ->
                            SqlTypeExp ftype
    where
        ftype = unboundFieldType field

attrSqlType :: FieldAttr -> Maybe Text
attrSqlType = \case
    FieldAttrSqltype x -> Just x
    _ -> Nothing

data SqlTypeExp
    = SqlTypeExp FieldType
    | SqlType' SqlType
    | SqlTypeReference EntityNameHS
    deriving Show

liftSqlTypeExp :: SqlTypeExp -> Q Exp
liftSqlTypeExp ste =
    case ste of
        SqlType' t ->
            lift t
        SqlTypeExp ftype -> do
            let
                typ = ftToType ftype
                mtyp = ConT ''Proxy `AppT` typ
                typedNothing = SigE (ConE 'Proxy) mtyp
            pure $ VarE 'sqlType `AppE` typedNothing
        SqlTypeReference entNameHs -> do
            let
                entNameId :: Name
                entNameId =
                    mkName $ T.unpack (unEntityNameHS entNameHs) <> "Id"

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


type EmbedEntityMap = M.Map EntityNameHS ()

constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap
constructEmbedEntityMap =
    M.fromList . fmap
        (\ent ->
                ( entityHaskell (unboundEntityDef ent)
                -- , toEmbedEntityDef (unboundEntityDef ent)
                , ()
                )
        )

lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity allEntities field = do
    let mfieldTy = Just $ fieldType field
    entName <- EntityNameHS <$> asum
        [ do
            FTTypeCon _ t <- mfieldTy
            stripSuffix "Id" t
        , do
            FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- mfieldTy
            pure entName
        , do
            FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- 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 =
    M.fromList . fmap (\ent -> (entityHaskell (unboundEntityDef ent), ent))

data FTTypeConDescr = FTKeyCon Text
    deriving 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 _ (FTTypeCon Just{} _) =
    Left Nothing
mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) =
    maybe (Left Nothing) (\_ -> Right name) $ M.lookup name ents
mEmbedded _ (FTTypePromoted _) =
    Left Nothing
mEmbedded ents (FTList x) =
    mEmbedded ents x
mEmbedded _ (FTApp (FTTypeCon Nothing "Key") (FTTypeCon _ a)) =
    Left $ Just $ FTKeyCon $ a <> "Id"
mEmbedded _ (FTApp _ _) =
    Left Nothing
mEmbedded _ (FTLit _) =
    Left Nothing

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

setFieldReference :: ReferenceDef -> FieldDef -> FieldDef
setFieldReference ref field = 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 mps = mkPersistWith 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 mps preexistingEntities ents' = do
    let
        (embedEntityMap, predefs) =
            preprocessUnboundDefs preexistingEntities ents'
        allEnts =
            embedEntityDefs preexistingEntities
            $ fmap (setDefaultIdFields mps)
            $ predefs
        entityMap =
            constructEntityMap allEnts
        preexistingSet =
            Set.fromList $ map getEntityHaskellName preexistingEntities
        newEnts =
            filter
                (\e -> getUnboundEntityNameHS e `Set.notMember` preexistingSet)
                allEnts
    ents <- filterM shouldGenerateCode 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 mps ued =
    case unboundPrimarySpec ued of
        NaturalKey _ ->
            instanceOkay
        SurrogateKey uidDef -> do
            let attrs =
                    unboundIdAttrs uidDef
                isDefaultFieldAttr = \case
                    FieldAttrDefault _ ->
                        True
                    _ ->
                        False
            case unboundIdType uidDef of
                Nothing ->
                    instanceOkay
                Just _ ->
                    case List.find isDefaultFieldAttr attrs of
                        Nothing ->
                            badInstance
                        Just _ -> do
                            instanceOkay

        DefaultKey _ ->
            instanceOkay

  where
    typ :: Type
    typ = genericDataType mps (getUnboundEntityNameHS ued) backendT

    mkInstance merr =
        InstanceD Nothing (maybe id (:) merr withPersistStoreWriteCxt) (ConT ''SafeToInsert `AppT` typ) []
    instanceOkay =
        pure
            [ mkInstance Nothing
            ]
    badInstance = do
        err <- [t| TypeError (SafeToInsertErrorMessage $(pure typ)) |]
        pure
            [ mkInstance (Just err)
            ]

    withPersistStoreWriteCxt =
        if mpsGeneric mps
            then
                [ConT ''PersistStoreWrite `AppT` backendT]
            else
                []


-- we can't just use 'isInstance' because TH throws an error
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode ed = do
    mtyp <- lookupTypeName entityName
    case mtyp of
        Nothing -> do
            pure True
        Just typeName -> do
            instanceExists <- isInstance ''PersistEntity [ConT typeName]
            pure (not instanceExists)
  where
    entityName =
        T.unpack . unEntityNameHS . getEntityHaskellName . unboundEntityDef $ ed

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

setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields mps ued
    | defaultIdType ued =
        overEntityDef
            (setEntityIdDef (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed)))
            ued
    | otherwise =
        ued
  where
    ed =
        unboundEntityDef ued
    setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef
    setToMpsDefault iid (EntityIdField fd) =
        EntityIdField fd
            { fieldType =
                iidFieldType iid (getEntityHaskellName ed)
            , fieldSqlType =
                iidFieldSqlType iid
            , fieldAttrs =
                let
                    def =
                        toList (FieldAttrDefault <$> iidDefault iid)
                    maxlen =
                        toList (FieldAttrMaxlen <$> iidMaxLen iid)
                 in
                    def <> maxlen <> fieldAttrs fd
            , fieldIsImplicitIdColumn =
                True
            }
    setToMpsDefault _ x =
        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 ued =
    ued
        { unboundEntityFields =
            filter isHaskellUnboundField (unboundEntityFields ued)
        }

-- | Settings to be passed to the 'mkPersist' function.
data MkPersistSettings = MkPersistSettings
    { 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)
    -- @
    , 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.
    , mpsPrefixFields :: Bool
    -- ^ Prefix field names with the model name. Default: True.
    --
    -- Note: this field is deprecated. Use the mpsFieldLabelModifier  and
    -- 'mpsConstraintLabelModifier' instead.
    , mpsFieldLabelModifier :: Text -> Text -> Text
    -- ^ Customise the field accessors and lens names using the entity and field
    -- name.  Both arguments are upper cased.
    --
    -- Default: appends entity and field.
    --
    -- Note: this setting is ignored if mpsPrefixFields is set to False.
    --
    -- @since 2.11.0.0
    , 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
    , mpsConstraintLabelModifier :: Text -> Text -> Text
    -- ^ Customise the Constraint names using the entity and field name. The
    -- result should be a valid haskell type (start with an upper cased letter).
    --
    -- Default: appends entity and field
    --
    -- Note: this setting is ignored if mpsPrefixFields is set to False.
    --
    -- @since 2.11.0.0
    , mpsEntityHaddocks :: Bool
    -- ^ Generate Haddocks from entity documentation comments. Default: False.
    --
    -- @since 2.14.6.0
    , 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
    --      }
    -- @
    , mpsGenerateLenses :: Bool
    -- ^ Instead of generating normal field accessors, generator lens-style
    -- accessors.
    --
    -- Default: False
    --
    -- @since 1.3.1
    , mpsDeriveInstances :: [Name]
    -- ^ Automatically derive these typeclass instances for all record and key
    -- types.
    --
    -- Default: []
    --
    -- @since 2.8.1
    , mpsImplicitIdDef :: ImplicitIdDef
    -- ^ TODO: document
    --
    -- @since 2.13.0.0
    , 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 iid mps =
    mps { mpsImplicitIdDef = iid }

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

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

-- | Create an @MkPersistSettings@ with default values.
mkPersistSettings
    :: Type -- ^ Value for 'mpsBackend'
    -> MkPersistSettings
mkPersistSettings backend = MkPersistSettings
    { mpsBackend = backend
    , mpsGeneric = False
    , mpsPrefixFields = True
    , mpsFieldLabelModifier = (++)
    , mpsAvoidHsKeyword = (++ "_")
    , mpsConstraintLabelModifier = (++)
    , mpsEntityHaddocks = False
    , mpsEntityJSON = Just EntityJSON
        { entityToJSON = 'entityIdToJSON
        , entityFromJSON = 'entityIdFromJSON
        }
    , mpsGenerateLenses = False
    , mpsDeriveInstances = []
    , mpsImplicitIdDef =
        autoIncrementingInteger
    , mpsCamelCaseCompositeKeySelector = False
    }

-- | Use the 'SqlPersist' backend.
sqlSettings :: MkPersistSettings
sqlSettings = mkPersistSettings $ ConT ''SqlBackend

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

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

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

    let (stocks, anyclasses) = partitionEithers (fmap stratFor names)
    let stockDerives = do
            guard (not (null stocks))
            pure (DerivClause (Just StockStrategy) (fmap ConT stocks))
        anyclassDerives = do
            guard (not (null anyclasses))
            pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses))
    unless (null anyclassDerives) $ do
        requireExtensions [[DeriveAnyClass]]
    let dec = DataD [] nameFinal paramsFinal
                Nothing
                constrs
                (stockDerives <> anyclassDerives)
#if MIN_VERSION_template_haskell(2,18,0)
    when (mpsEntityHaddocks mps) $ do
        forM_ cols $ \((name, _, _), maybeComments) -> do
            case maybeComments of
                Just comment -> addModFinalizer $
                    putDoc (DeclDoc name) (unpack comment)
                Nothing -> pure ()
        case entityComments (unboundEntityDef entDef) of
            Just doc -> do
                addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc)
            _ -> pure ()
#endif
    pure dec

  where
    stratFor n =
        if n `elem` stockClasses then
            Left n
        else
            Right n

    stockClasses =
        Set.fromList (fmap mkName
        [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable", "Lift"
        ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable, ''Lift
        ]
        )

    (nameFinal, paramsFinal)
        | mpsGeneric mps =
            ( mkEntityDefGenericName entDef
            , [ mkPlainTV backendName
              ]
            )

        | otherwise =
            (mkEntityDefName entDef, [])

    cols :: [(VarBangType, Maybe Text)]
    cols = do
        fieldDef <- getUnboundFieldDefs entDef
        let
            recordNameE =
                fieldDefToRecordName mps entDef fieldDef
            strictness =
                if unboundFieldStrict fieldDef
                then isStrict
                else notStrict
            fieldIdType =
                maybeIdType mps entityMap fieldDef Nothing Nothing
            fieldComments =
                unboundFieldComments fieldDef
        pure ((recordNameE, strictness, fieldIdType), fieldComments)

    constrs
        | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef
        | otherwise = [RecC (mkEntityDefName entDef) (map fst cols)]

    sumCon fieldDef = NormalC
        (sumConstrName mps entDef fieldDef)
        [(notStrict, maybeIdType mps entityMap fieldDef Nothing Nothing)]

uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
uniqueTypeDec mps entityMap entDef =
    DataInstD
        []
#if MIN_VERSION_template_haskell(2,15,0)
        Nothing
        (AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT))
#else
        ''Unique
        [genericDataType mps (getUnboundEntityNameHS entDef) backendT]
#endif
        Nothing
        (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef))
        []

mkUnique :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) =
    NormalC (mkConstraintName constr) $ toList types
  where
    types =
      fmap (go . flip lookup3 (getUnboundFieldDefs entDef) . unFieldNameHS . fst) fields

    force = "!force" `elem` attrs

    go :: (UnboundFieldDef, IsNullable) -> (Strict, Type)
    go (_, Nullable _) | not force = error nullErrMsg
    go (fd, y) = (notStrict, maybeIdType mps entityMap fd Nothing (Just y))

    lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
    lookup3 s [] =
        error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr
    lookup3 x (fd:rest)
        | x == unFieldNameHS (unboundFieldNameHS fd) =
            (fd, isUnboundFieldNullable fd)
        | otherwise =
            lookup3 x rest

    nullErrMsg =
      mconcat [ "Error:  By default Persistent disallows NULLables in an uniqueness "
              , "constraint.  The semantics of how NULL interacts with those constraints "
              , "is non-trivial:  most SQL implementations will not consider two NULL "
              , "values to be equal for the purposes of an uniqueness constraint, "
              , "allowing insertion of more than one row with a NULL value for the "
              , "column in question.  If you understand this feature of SQL and still "
              , "intend to add a uniqueness constraint here,    *** Use a \"!force\" "
              , "attribute on the end of the line that defines your uniqueness "
              , "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 mps entityMap fieldDef mbackend mnull =
    maybeTyp mayNullable idType
  where
    mayNullable =
        case mnull of
            Just (Nullable ByMaybeAttr) ->
                True
            _ ->
                maybeNullable fieldDef
    idType =
        fromMaybe (ftToType $ unboundFieldType fieldDef) $ do
            typ <- extractForeignRef entityMap 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 oldName@(Name (OccName nm) nameFlavor) =
        case stripSuffix "Id" (T.pack nm) of
            Nothing ->
                ConT oldName
            Just name ->
                ConT ''Key
                `AppT` do
                    ConT $ Name (OccName (T.unpack name)) 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 em fieldTypeText = do
        let
            mmodelIdString = do
                fieldTypeNoId <- stripSuffix "Id" fieldTypeText
                _ <- M.lookup (EntityNameHS fieldTypeNoId) em
                pure (T.unpack fieldTypeText)
        case mmodelIdString of
            Nothing ->
                pure Nothing
            Just modelIdString -> do
                mIdName <- lookupTypeName modelIdString
                pure $ fmap _removeIdFromTypeSuffix mIdName

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

backendDataType :: MkPersistSettings -> Type
backendDataType mps
    | mpsGeneric mps = backendT
    | otherwise = mpsBackend 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 mps name backend
    | mpsGeneric mps =
        ConT (mkEntityNameHSGenericName name) `AppT` backend
    | otherwise =
        ConT $ mkEntityNameHSName name

degen :: [Clause] -> [Clause]
degen [] =
    let err = VarE 'error `AppE` LitE (StringL
                "Degenerate case, should never happen")
     in [normalClause [WildP] err]
degen x = 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 mps ed = do
    let isSum = unboundEntitySum ed
        fields = getUnboundFieldDefs ed
    clauses <-
        if isSum
            then sequence $ zipWith goSum fields [1..]
            else fmap return go
    return $ FunD 'toPersistFields clauses
  where
    go :: Q Clause
    go = do
        xs <- sequence $ replicate fieldCount $ newName "x"
        let name = mkEntityDefName ed
            pat = conp name $ fmap VarP xs
        sp <- [|toPersistValue|]
        let bod = ListE $ fmap (AppE sp . VarE) xs
        return $ normalClause [pat] bod

    fieldCount = length (getUnboundFieldDefs ed)

    goSum :: UnboundFieldDef -> Int -> Q Clause
    goSum fieldDef idx = do
        let name = sumConstrName mps ed fieldDef
        enull <- [|PersistNull|]
        let beforeCount = idx - 1
            afterCount = fieldCount - idx
            before = replicate beforeCount enull
            after = replicate afterCount enull
        x <- newName "x"
        sp <- [|toPersistValue|]
        let body = ListE $ mconcat
                [ before
                , [sp `AppE` VarE x]
                , after
                ]
        return $ normalClause [conp name [VarP x]] body

mkToFieldNames :: [UniqueDef] -> Q Dec
mkToFieldNames pairs = do
    pairs' <- mapM go pairs
    return $ FunD 'persistUniqueToFieldNames $ degen pairs'
  where
    go (UniqueDef constr _ names _) = do
        names' <- lift names
        return $
            normalClause
                [RecP (mkConstraintName constr) []]
                names'

mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues pairs = do
    pairs' <- mapM go pairs
    return $ FunD 'persistUniqueToValues $ degen pairs'
  where
    go :: UniqueDef -> Q Clause
    go (UniqueDef constr _ names _) = do
        xs <- mapM (const $ newName "x") names
        let pat = conp (mkConstraintName constr) $ fmap VarP $ toList xs
        tpv <- [|toPersistValue|]
        let bod = ListE $ fmap (AppE tpv . VarE) $ toList xs
        return $ normalClause [pat] bod

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

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

-- needs:
--
-- * getEntityFields
--     * sumConstrName on field
-- * fromValues
-- * entityHaskell
-- * sumConstrName
-- * entityDefConE
--
--
mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues mps entDef
    | unboundEntitySum 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]
    | otherwise =
        fromValues entDef "fromPersistValues" entE
        $ fmap unboundFieldNameHS
        $ filter isHaskellUnboundField
        $ getUnboundFieldDefs entDef
  where
    entName = unEntityNameHS $ getUnboundEntityNameHS entDef
    mkClauses _ [] = return []
    mkClauses before (field:after) = do
        x <- newName "x"
        let null' = conp 'PersistNull []
            pat = ListP $ mconcat
                [ fmap (const null') before
                , [VarP x]
                , fmap (const null') after
                ]
            constr = ConE $ sumConstrName mps entDef field
        fs <- [|fromPersistValue $(return $ VarE x)|]
        let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x
        let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) []
        clauses <- mkClauses (field : before) after
        return $ clause : clauses
    entE = entityDefConE 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 sa sbt afb s = fmap (sbt s) (afb $ sa s)

fmapE :: Exp
fmapE = VarE 'fmap

unboundEntitySum :: UnboundEntityDef -> Bool
unboundEntitySum = entitySum . unboundEntityDef

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

fieldUpd :: Name -- ^ constructor name
    -> [Name] -- ^ list of field names
    -> Exp -- ^ record value
    -> Name -- ^ field name to update
    -> Exp -- ^ new value
    -> Q Exp
fieldUpd con names record name new = do
    pats <-
        fmap mconcat $ forM names $ \k -> do
            varName <- VarP <$> newName (nameBase k)
            pure [(k, varName) | k /= name]

    pure $ CaseE record
        [ Match (RecP con pats) (NormalB body) []]
    where
        body = RecConE con
            [ if k == name then (name, new) else (k, VarE k)
            | k <- names
            ]

mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]
mkLensClauses mps entDef _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 = normalClause
            [conp (keyIdName entDef) []]
            (lens' `AppE` getId `AppE` 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 = fieldDefToRecordName mps entDef <$> getUnboundFieldDefs entDef
    toClause lens' getVal dot keyVar valName xName fieldDef fieldName = do
        setter <- mkSetter
        pure $ normalClause
            [conp (filterConName mps entDef fieldDef) []]
            (lens' `AppE` getter `AppE` setter)
      where
        defName = mkEntityDefName entDef
        getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal)
        mkSetter = do
            updExpr <- fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName)
            pure $ LamE
                [ conp 'Entity [VarP keyVar, VarP valName]
                , VarP xName
                ]
                $ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr

    toSumClause lens' keyVar valName xName fieldDef = normalClause
        [conp (filterConName mps entDef fieldDef) []]
        (lens' `AppE` getter `AppE` setter)
      where
        emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) []
        getter = LamE
            [ conp 'Entity [WildP, VarP valName]
            ] $ CaseE (VarE valName)
            $ Match (conp (sumConstrName mps entDef fieldDef) [VarP xName]) (NormalB $ VarE xName) []

            -- FIXME It would be nice if the types expressed that the Field is
            -- a sum type and therefore could result in Maybe.
            : if length (getUnboundFieldDefs entDef) > 1 then [emptyMatch] else []
        setter = LamE
            [ conp 'Entity [VarP keyVar, WildP]
            , VarP xName
            ]
            $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps entDef fieldDef) `AppE` VarE 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 mps entDef = do
    (instDecs, i) <-
      if mpsGeneric mps
        then if not useNewtype
               then do pfDec <- pfInstD
                       return (pfDec, supplement [''Generic])
               else do gi <- genericNewtypeInstances
                       return (gi, supplement [])
        else if not useNewtype
               then do pfDec <- pfInstD
                       return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])
                else do
                    let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
                    if customKeyType
                      then return ([], allInstances)
                      else do
                        bi <- backendKeyI
                        return (bi, allInstances)

    requirePersistentExtensions

    -- Always use StockStrategy for Lift/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 = [''Lift, ''Show, ''Read]
        deriveClauses = fmap (\typeclass ->
            if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses)
                then DerivClause (Just StockStrategy) [(ConT typeclass)]
                else DerivClause (Just NewtypeStrategy) [(ConT typeclass)]
            ) i

#if MIN_VERSION_template_haskell(2,15,0)
    let kd = if useNewtype
               then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses
               else DataInstD    [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses
#else
    let kd = if useNewtype
               then NewtypeInstD [] k [recordType] Nothing dec deriveClauses
               else DataInstD    [] k [recordType] Nothing [dec] deriveClauses
#endif
    return (kd, instDecs)
  where
    keyConE = keyConExp entDef
    unKeyE = unKeyExp entDef
    dec = RecC (keyConName entDef) (toList $ keyFields mps entDef)
    k = ''Key
    recordType =
        genericDataType mps (getUnboundEntityNameHS entDef) backendT
    pfInstD = -- FIXME: generate a PersistMap instead of PersistList
      [d|instance PersistField (Key $(pure recordType)) where
            toPersistValue = PersistList . keyToValues
            fromPersistValue (PersistList l) = keyFromValues l
            fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got
         instance PersistFieldSql (Key $(pure recordType)) where
            sqlType _ = SqlString
         instance ToJSON (Key $(pure recordType))
         instance FromJSON (Key $(pure recordType))
      |]

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

    genericNewtypeInstances = do
        requirePersistentExtensions

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

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

    useNewtype = pkNewtype mps entDef
    customKeyType =
        or
            [ not (defaultIdType entDef)
            , not useNewtype
            , isJust (entityPrimary (unboundEntityDef entDef))
            , not isBackendKey
            ]

    isBackendKey =
        case getImplicitIdType mps of
            ConT bk `AppT` _
                | bk == ''BackendKey ->
                    True
            _ ->
                False

    supplement :: [Name] -> [Name]
    supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps)

-- | Returns 'True' if the key definition has less than 2 fields.
--
-- @since 2.11.0.0
pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
pkNewtype mps entDef = length (keyFields mps entDef) < 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 entDef =
    case unboundPrimarySpec entDef of
        DefaultKey _ ->
            True
        _ ->
            False

keyFields :: MkPersistSettings -> UnboundEntityDef -> NonEmpty (Name, Strict, Type)
keyFields mps entDef =
    case unboundPrimarySpec entDef of
        NaturalKey ucd ->
            fmap naturalKeyVar (unboundCompositeCols ucd)
        DefaultKey _ ->
            pure . idKeyVar $ getImplicitIdType mps
        SurrogateKey k ->
            pure . idKeyVar $ case unboundIdType k of
                Nothing ->
                    getImplicitIdType mps
                Just ty ->
                    ftToType ty
  where
    unboundFieldDefs =
        getUnboundFieldDefs entDef
    naturalKeyVar fieldName =
        case findField fieldName unboundFieldDefs of
            Nothing ->
                error "column not defined on entity"
            Just unboundFieldDef ->
                ( keyFieldName mps entDef (unboundFieldNameHS unboundFieldDef)
                , notStrict
                , ftToType $ unboundFieldType unboundFieldDef
                )

    idKeyVar ft =
        ( unKeyName entDef
        , notStrict
        , ft
        )

findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
findField fieldName =
    List.find ((fieldName ==) . unboundFieldNameHS)

mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyToValues mps entDef = do
    recordN <- newName "record"
    FunD 'keyToValues . pure <$>
        case unboundPrimarySpec entDef of
            NaturalKey ucd -> do
                normalClause [VarP recordN] <$>
                    toValuesPrimary recordN ucd
            _ -> do
                normalClause [] <$>
                    [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|]
  where
    toValuesPrimary recName ucd =
        ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd)
    f recName fieldNameHS =
        [|
        toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE recName))
        |]
    keyFieldSel name
        = fieldSel (keyConName entDef) (keyFieldName mps entDef name)

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

-- needs:
--
-- * entityPrimary
-- * keyConExp entDef
mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues _mps entDef =
    FunD 'keyFromValues <$>
        case unboundPrimarySpec entDef of
            NaturalKey ucd ->
                fromValues entDef "keyFromValues" keyConE (toList $ unboundCompositeCols ucd)
            _ -> do
                e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
                return [normalClause [] e]
  where
    keyConE = keyConExp entDef

headNote :: [PersistValue] -> PersistValue
headNote = \case
  [x] -> x
  xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show 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 entDef funName constructExpr fields = do
    x <- newName "x"
    let
        funMsg =
            mconcat
                [ entityText entDef
                , ": "
                , funName
                , " failed on: "
                ]
    patternMatchFailure <-
        [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
    suc <- patternSuccess
    return [ suc, normalClause [VarP x] patternMatchFailure ]
  where
    tableName =
        unEntityNameDB (entityDB (unboundEntityDef entDef))
    patternSuccess =
        case fields of
            [] -> do
                rightE <- [|Right|]
                return $ normalClause [ListP []] (rightE `AppE` constructExpr)
            _ -> do
                x1 <- newName "x1"
                restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields]
                (fpv1:mkPersistValues) <- mapM mkPersistValue fields
                app1E <- [|(<$>)|]
                let conApp = infixFromPersistValue app1E fpv1 constructExpr x1
                applyE <- [|(<*>)|]
                let applyFromPersistValue = infixFromPersistValue applyE

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

    infixFromPersistValue applyE fpv exp name =
        UInfixE exp applyE (fpv `AppE` VarE name)

    mkPersistValue field =
        let fieldName = unFieldNameHS 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 tableName fieldName err = mconcat
    [ "Couldn't parse field `"
    , fieldName
    , "` from table `"
    , tableName
    , "`. "
    , err
    ]

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

    entityDefExp <- liftAndFixKeys mps embedEntityMap entityMap preDef
    let
        entDef =
            fixEntityDef preDef
    fields <- mkFields mps entityMap entDef
    let name = mkEntityDefName entDef
    let clazz = ConT ''PersistEntity `AppT` 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
            | mpsGeneric mps = (:) $
                TySynD name [] $
                    genericDataType mps entName $ mpsBackend mps
            | otherwise = id

    lensClauses <- mkLensClauses mps entDef genDataType

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

    [keyFromRecordM'] <-
        case unboundPrimarySpec entDef of
            NaturalKey ucd -> do
                let keyFields' = fieldNameToRecordName mps entDef <$> unboundCompositeCols ucd
                keyFieldNames' <- forM keyFields' $ \fieldName -> do
                                         fieldVarName <- newName (nameBase fieldName)
                                         return (fieldName, fieldVarName)

                let keyCon = keyConName entDef
                    constr =
                        foldl'
                            AppE
                            (ConE keyCon)
                            (VarE . snd <$> keyFieldNames')
                    keyFromRec = varP 'keyFromRecordM
                    fieldPat = [(fieldName, VarP fieldVarName) | (fieldName, fieldVarName) <- toList keyFieldNames']
                    lam = LamE [RecP name fieldPat ] constr
                [d|
                    $(keyFromRec) = Just $(pure lam)
                    |]

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

    dtd <- dataTypeDec mps entityMap entDef
    let
        allEntDefs =
            entityFieldTHCon <$> efthAllFields fields
        allEntDefClauses =
            entityFieldTHClause <$> efthAllFields fields

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


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

    return $ addSyn $
       dtd : mconcat fkc `mappend`
      ( [ TySynD (keyIdName entDef) [] $
            ConT ''Key `AppT` ConT name
      , instanceD instanceConstraint clazz
        [ uniqueTypeDec mps entityMap entDef
        , keyTypeDec
        , keyToValues'
        , keyFromValues'
        , keyFromRecordM'
        , mkTabulateA
        , FunD 'entityDef [normalClause [WildP] entityDefExp]
        , tpf
        , FunD 'fromPersistValues fpv
        , toFieldNames
        , utv
        , puk
#if MIN_VERSION_template_haskell(2,15,0)
        , DataInstD
            []
            Nothing
            (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ"))
            Nothing
            allEntDefs
            []
#else
        , DataInstD
            []
            ''EntityField
            [ genDataType
            , VarT $ mkName "typ"
            ]
            Nothing
            allEntDefs
            []
#endif
        , FunD 'persistFieldDef allEntDefClauses
#if MIN_VERSION_template_haskell(2,15,0)
        , TySynInstD
            (TySynEqn
               Nothing
               (AppT (ConT ''PersistEntityBackend) genDataType)
               (backendDataType mps))
#else
        , TySynInstD
            ''PersistEntityBackend
            (TySynEqn
               [genDataType]
               (backendDataType mps))
#endif
        , FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)]
        , FunD 'fieldLens lensClauses
        ]
      ] `mappend` lenses) `mappend` keyInstanceDecs
  where
    genDataType =
        genericDataType mps entName backendT
    entName =
        getUnboundEntityNameHS preDef

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

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

stripIdFieldDef :: EntityFieldTH -> EntityFieldTH
stripIdFieldDef efth = efth
    { entityFieldTHClause =
        go (entityFieldTHClause efth)
    }
  where
    go (Clause ps bdy ds) =
        Clause ps bdy' ds
      where
        bdy' =
            case bdy of
                NormalB e ->
                    NormalB $ AppE (VarE 'stripIdFieldImpl) e
                _ ->
                    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 eid =
    case eid of
        EntityIdField fd -> fd
        EntityIdNaturalKey cd ->
            case compositeFields cd of
                (x :| xs) ->
                    case xs of
                        [] ->
                            x
                        _ ->
                            dummyFieldDef
  where
    dummyFieldDef =
        FieldDef
            { fieldHaskell =
                FieldNameHS "Id"
            , fieldDB =
                FieldNameDB "__composite_key_no_id__"
            , fieldType =
                FTTypeCon Nothing "__Composite_Key__"
            , fieldSqlType =
                SqlOther "Composite Key"
            , fieldAttrs =
                []
            , fieldStrict =
                False
            , fieldReference =
                NoReference
            , fieldCascade =
                noCascade
            , fieldComments =
                Nothing
            , fieldGenerated =
                Nothing
            , fieldIsImplicitIdColumn =
                False
            }

mkFields :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
mkFields mps entityMap entDef =
    EntityFieldsTH
        <$> mkIdField mps entDef
        <*> mapM (mkField mps entityMap entDef) (getUnboundFieldDefs entDef)

mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances mps entDef = do
    requirePersistentExtensions
    case entityUniques (unboundEntityDef entDef) of
        [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne
        [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey
        (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey
  where
    requireUniquesPName = 'requireUniquesP
    onlyUniquePName = 'onlyUniqueP
    typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx
    typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx

    withPersistStoreWriteCxt =
        if mpsGeneric mps
            then do
                write <- [t|PersistStoreWrite $(pure backendT) |]
                pure [write]
            else do
                pure []

    typeErrorNoneCtx = do
        tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|]
        (tyErr :) <$> withPersistStoreWriteCxt

    typeErrorMultipleCtx = do
        tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|]
        (tyErr :) <$> withPersistStoreWriteCxt

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

    mkImpossible name =
        [ FunD name
            [ Clause
                [ WildP ]
                (NormalB
                    (VarE 'error `AppE` LitE (StringL "impossible"))
                )
                []
            ]
        ]

    typeErrorAtLeastOne :: Q [Dec]
    typeErrorAtLeastOne = do
        let impl = mkImpossible requireUniquesPName
        cxt <- typeErrorMultipleCtx
        pure [instanceD cxt atLeastOneUniqueKeyClass impl]

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

    atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType
    onlyOneUniqueKeyClass =  ConT ''OnlyOneUniqueKey `AppT` genDataType

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

    genDataType =
        genericDataType mps (getUnboundEntityNameHS entDef) backendT

entityText :: UnboundEntityDef -> Text
entityText = unEntityNameHS . getUnboundEntityNameHS

mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkLenses mps _ _ | not (mpsGenerateLenses mps) = return []
mkLenses _ _ ent | entitySum (unboundEntityDef ent) = return []
mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` fieldNames) $ \(field, fieldName) -> do
    let lensName = mkEntityLensName mps ent field
    needleN <- newName "needle"
    setterN <- newName "setter"
    fN <- newName "f"
    aN <- newName "a"
    yN <- newName "y"
    let needle = VarE needleN
        setter = VarE setterN
        f = VarE fN
        a = VarE aN
        y = VarE yN
        fT = mkName "f"
        -- 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 = backendName
        backend2 = backendName
        aT =
            maybeIdType mps entityMap field (Just backend1) Nothing
        bT =
            maybeIdType mps entityMap field (Just backend2) Nothing
        mkST backend =
            genericDataType mps (getUnboundEntityNameHS ent) (VarT backend)
        sT = mkST backend1
        tT = mkST backend2
        t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2
        vars = mkForallTV fT
             : (if mpsGeneric mps then [mkForallTV 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 = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent

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

mkForallTV :: Name -> TyVarBndr Specificity
mkForallTV n = PlainTV n SpecifiedSpec
#elif MIN_VERSION_template_haskell(2,17,0)
mkPlainTV
    :: Name
    -> TyVarBndr ()
mkPlainTV 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 mps entDef foreignDef
    | foreignToPrimary (unboundForeignDef foreignDef) = do
        let
            fieldName =
                fieldNameToRecordName mps entDef
            fname =
                fieldName $ constraintToField $ foreignConstraintNameHaskell $ unboundForeignDef foreignDef
            reftableString =
                unpack $ unEntityNameHS $ foreignRefTableHaskell $ unboundForeignDef foreignDef
            reftableKeyName =
                mkName $ reftableString `mappend` "Key"
            tablename =
                mkEntityDefName entDef
            fieldStore =
                mkFieldStore entDef

        recordVarName <- newName "record_mkForeignKeysComposite"

        let
            mkFldE foreignName  =
                -- using coerce here to convince SqlBackendKey to go away
                VarE 'coerce `AppE`
                (VarE (fieldName foreignName) `AppE` VarE recordVarName)
            mkFldR ffr =
                let
                    e =
                        mkFldE (ffrSourceField ffr)
                in
                    case ffrTargetField ffr of
                        FieldNameHS "Id" ->
                            VarE 'toBackendKey `AppE`
                                e
                        _ ->
                            e
            foreignFieldNames foreignFieldList =
                case foreignFieldList of
                    FieldListImpliedId names ->
                        names
                    FieldListHasReferences refs ->
                        fmap ffrSourceField refs

            fldsE =
                getForeignNames $ (unboundForeignFields foreignDef)
            getForeignNames = \case
                FieldListImpliedId xs ->
                   fmap mkFldE xs
                FieldListHasReferences xs ->
                    fmap mkFldR xs

            nullErr n =
               error $ "Could not find field definition for: " <> show n
            fNullable =
                setNull
                   $ fmap (\n -> fromMaybe (nullErr n) $ getFieldDef n fieldStore)
                   $ foreignFieldNames
                   $ unboundForeignFields foreignDef
            mkKeyE =
                foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE
            fn =
                FunD fname [normalClause [VarP recordVarName] mkKeyE]

            keyTargetTable =
                maybeTyp fNullable $ ConT ''Key `AppT` ConT (mkName reftableString)

        sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |]
        pure
            [ SigD fname sigTy
            , fn
            ]

    | otherwise =
        pure []
  where
    constraintToField = FieldNameHS . unConstraintNameHS


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

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

entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue
entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues
    where
        columnNames = fmap (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity)))
        fieldsAsPersistValues = fmap toPersistValue $ toPersistFields entity

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

    let columnMap = HM.fromList persistMap
        lookupPersistValueByColumnName :: String -> PersistValue
        lookupPersistValueByColumnName columnName =
            fromMaybe PersistNull (HM.lookup (pack columnName) columnMap)

    fromPersistValues $ 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 mps entDef = do
    sqlStringConstructor' <- [|SqlString|]
    toPersistValueImplementation <- [|entityToPersistValueHelper|]
    fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|]

    return
        [ persistFieldInstanceD (mpsGeneric mps) typ
            [ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ]
            , FunD 'fromPersistValue
                [ normalClause [] fromPersistValueImplementation ]
            ]
        , persistFieldSqlInstanceD (mpsGeneric mps) typ
            [ sqlTypeFunD sqlStringConstructor'
            ]
        ]
  where
    typ =
        genericDataType mps (entityHaskell (unboundEntityDef entDef)) backendT
    entFields =
        filter isHaskellUnboundField $ getUnboundFieldDefs entDef
    columnNames =
        fmap (unpack . unFieldNameHS . unboundFieldNameHS) 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 fs x = mconcat <$> mapM ($ x) 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 entityList entityDefs = do
    let entityListName = mkName entityList
    edefs <- fmap ListE
        . forM entityDefs
        $ \entDef ->
            let entityType = entityDefConT entDef
             in [|entityDef (Proxy :: Proxy $(entityType))|]
    typ <- [t|[EntityDef]|]
    pure
        [ SigD entityListName typ
        , ValD (VarP entityListName) (NormalB edefs) []
        ]

mkUniqueKeys :: UnboundEntityDef -> Q Dec
mkUniqueKeys def | entitySum (unboundEntityDef def) =
    return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])]
mkUniqueKeys def = do
    c <- clause
    return $ FunD 'persistUniqueKeys [c]
  where
    clause = do
        xs <- forM (getUnboundFieldDefs def) $ \fieldDef -> do
            let x = unboundFieldNameHS fieldDef
            x' <- newName $ '_' : unpack (unFieldNameHS x)
            return (x, x')
        let pcs = fmap (go xs) $ entityUniques $ unboundEntityDef def
        let pat = conp
                (mkEntityDefName def)
                (fmap (VarP . snd) xs)
        return $ normalClause [pat] (ListE pcs)

    go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
    go xs (UniqueDef name _ cols _) =
        foldl' (go' xs) (ConE (mkConstraintName name)) (toList $ fmap fst cols)

    go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
    go' xs front col =
        let col' =
                fromMaybe (error $ "failed in go' while looking up col=" <> show col) (lookup col xs)
         in front `AppE` VarE col'

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

typeInstanceD
    :: Name
    -> Bool -- ^ include PersistStore backend constraint
    -> Type
    -> [Dec]
    -> Dec
typeInstanceD clazz hasBackend typ =
    instanceD ctx (ConT clazz `AppT` typ)
  where
    ctx
        | hasBackend = [mkClassP ''PersistStore [backendT]]
        | otherwise = []

persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint
                      -> Type -> [Dec] -> Dec
persistFieldInstanceD = typeInstanceD ''PersistField

persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint
                         -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD = 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 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 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 defs=
    forM_ (filter isMigrated defs) $ \def ->
        migrate defs def
  where
    isMigrated def = pack "no-migrate" `notElem` entityAttrs 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 fun eds = do
    let entityDefListName = ("entityDefListFor" <> fun)
    body <- [| migrateModels $(varE (mkName entityDefListName)) |]
    edList <- mkEntityDefList entityDefListName eds
    pure $ edList <>
        [ SigD (mkName fun) (ConT ''Migration)
        , FunD (mkName fun) [normalClause [] body]
        ]

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

-- Ent
--   fieldName FieldType
--
-- forall . typ ~ FieldType => EntFieldName
--
-- EntFieldName = FieldDef ....
--
-- Field Def Accessors Required:
mkField :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UnboundFieldDef -> Q EntityFieldTH
mkField mps entityMap et fieldDef = do
    let
        con =
            ForallC
                []
                [mkEqualP (VarT $ mkName "typ") fieldT]
                $ NormalC name []
        fieldT =
            maybeIdType mps entityMap fieldDef Nothing Nothing
    bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef)
    let cla = normalClause
                [conp name []]
                bod
    return $ EntityFieldTH con cla
  where
    name = filterConName mps et fieldDef

mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
mkIdField mps ued = do
    let
        entityName =
            getUnboundEntityNameHS ued
        entityIdType
            | mpsGeneric mps =
                ConT ''Key `AppT` (
                    ConT (mkEntityNameHSGenericName entityName)
                    `AppT` backendT
                )
            | otherwise =
                ConT $ mkName $ (T.unpack $ unEntityNameHS entityName) ++ "Id"
        name =
            filterConName' mps entityName (FieldNameHS "Id")
    clause  <-
        fixPrimarySpec mps 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 prxy fieldNameHS =
    fromMaybe boom $ List.find ((fieldNameHS ==) . fieldHaskell) $ entityFields $ entityDef prxy
  where
    boom =
        error "Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name"

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

maybeNullable :: UnboundFieldDef -> Bool
maybeNullable fd = isUnboundFieldNullable fd == Nullable ByMaybeAttr

ftToType :: FieldType -> Type
ftToType = \case
    FTTypeCon Nothing t ->
        ConT $ mkName $ T.unpack t
    -- This type is generated from the Quasi-Quoter.
    -- Adding this special case avoids users needing to import Data.Int
    FTTypeCon (Just "Data.Int") "Int64" ->
        ConT ''Int64
    FTTypeCon (Just m) t ->
        ConT $ mkName $ unpack $ concat [m, ".", t]
    FTLit l ->
        LitT (typeLitToTyLit l)
    FTTypePromoted t ->
        PromotedT $ mkName $ T.unpack t
    FTApp x y ->
        ftToType x `AppT` ftToType y
    FTList x ->
        ListT `AppT` ftToType x

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

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

mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON _ def | ("json" `notElem` entityAttrs (unboundEntityDef def)) = return []
mkJSON mps (fixEntityDef -> def) = do
    requireExtensions [[FlexibleInstances]]
    pureE <- [|pure|]
    apE' <- [|(<*>)|]

    let objectE = VarE 'object
        withObjectE = VarE 'withObject
        dotEqualE = VarE '(.=)
        dotColonE = VarE '(.:)
        dotColonQE = VarE '(.:?)
#if MIN_VERSION_aeson(2,0,0)
        toKeyE = VarE 'Key.fromString
#else
        toKeyE = VarE 'pack
#endif
    obj <- newName "obj"
    let
        fields =
            getUnboundFieldDefs def

    xs <- mapM fieldToJSONValName fields

    let
        conName =
            mkEntityDefName def
        typ =
            genericDataType mps (entityHaskell (unboundEntityDef def)) backendT
        toJSONI =
            typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON']
          where
            toJSON' = FunD 'toJSON $ return $ normalClause
                [conp conName $ fmap VarP xs]
                (objectE `AppE` ListE pairs)
              where
                pairs = zipWith toPair fields xs
                toPair f x = InfixE
                    (Just (toKeyE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f)))
                    dotEqualE
                    (Just $ VarE x)
        fromJSONI =
            typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON']
          where
            entNameStrLit =
                StringL $ T.unpack (unEntityNameHS (getUnboundEntityNameHS def))
            parseJSONBody =
                withObjectE `AppE` LitE entNameStrLit `AppE` decoderImpl
            parseJSON' =
                FunD 'parseJSON [ normalClause [] parseJSONBody ]
            decoderImpl =
                LamE [VarP obj]
                    (foldl'
                        (\x y -> InfixE (Just x) apE' (Just y))
                        (pureE `AppE` ConE conName)
                        pulls
                    )
              where
                pulls =
                    fmap toPull fields
                toPull f = InfixE
                    (Just $ VarE obj)
                    (if maybeNullable f then dotColonQE else dotColonE)
                    (Just $ AppE toKeyE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f)

    case mpsEntityJSON mps of
        Nothing ->
            return [toJSONI, fromJSONI]
        Just entityJSON -> do
            entityJSONIs <- if mpsGeneric mps
              then [d|
                instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where
                    toJSON = $(varE (entityToJSON entityJSON))
                instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where
                    parseJSON = $(varE (entityFromJSON entityJSON))
                |]
              else [d|
                instance ToJSON (Entity $(pure typ)) where
                    toJSON = $(varE (entityToJSON entityJSON))
                instance FromJSON (Entity $(pure typ)) where
                    parseJSON = $(varE (entityFromJSON entityJSON))
                |]
            return $ toJSONI : fromJSONI : entityJSONIs

mkClassP :: Name -> [Type] -> Pred
mkClassP cla tys = foldl AppT (ConT cla) tys

mkEqualP :: Type -> Type -> Pred
mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright]

notStrict :: Bang
notStrict = Bang NoSourceUnpackedness NoSourceStrictness

isStrict :: Bang
isStrict = Bang NoSourceUnpackedness SourceStrict

instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD = InstanceD Nothing

-- | 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 = requireExtensions requiredExtensions
  where
    requiredExtensions = fmap pure
        [ DerivingStrategies
        , GeneralizedNewtypeDeriving
        , StandaloneDeriving
        , UndecidableInstances
        , MultiParamTypeClasses
        ]

mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do
    let
        entityHaskellName =
            getEntityHaskellName $ unboundEntityDef ed
        allFields =
            getUnboundFieldDefs ed
        mkEntityFieldConstr fieldHaskellName =
            conE $ filterConName' mps entityHaskellName fieldHaskellName
                :: Q Exp
    regularFields <- forM (toList allFields) $ \fieldDef -> do
        let
            fieldHaskellName =
                unboundFieldNameHS fieldDef

        let fieldNameT :: Q Type
            fieldNameT =
                litT $ strTyLit
                    $ T.unpack $ lowerFirstIfId
                    $ unFieldNameHS fieldHaskellName

            lowerFirstIfId "Id" = "id"
            lowerFirstIfId xs = xs

            fieldTypeT
                | fieldHaskellName == FieldNameHS "Id" =
                    conT ''Key `appT` recordNameT
                | otherwise =
                    pure $ maybeIdType mps entityMap fieldDef Nothing Nothing
            entityFieldConstr =
                mkEntityFieldConstr fieldHaskellName
        mkInstance fieldNameT fieldTypeT entityFieldConstr

    mkey <- do
                let
                    fieldHaskellName =
                        FieldNameHS "Id"
                    entityFieldConstr =
                        mkEntityFieldConstr fieldHaskellName
                    fieldTypeT =
                        conT ''Key `appT` recordNameT
                mkInstance [t|"id"|] fieldTypeT entityFieldConstr

    pure (mkey <> join regularFields)
  where
    nameG =
        mkEntityDefGenericName ed
    recordNameT
        | mpsGeneric mps =
            conT nameG `appT` varT backendName
        | otherwise =
            entityDefConT ed
    mkInstance fieldNameT fieldTypeT entityFieldConstr =
        [d|
            instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where
                symbolToField = $(entityFieldConstr)
            |]

-- | Pass in a list of lists of extensions, where any of the given
-- extensions will satisfy it. For example, you might need either GADTs or
-- ExistentialQuantification, so you'd write:
--
-- > requireExtensions [[GADTs, ExistentialQuantification]]
--
-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd
-- write:
--
-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]]
requireExtensions :: [[Extension]] -> Q ()
requireExtensions 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 <- filterM (fmap (not . or) . traverse isExtEnabled) requiredExtensions

  case mapMaybe listToMaybe unenabledExtensions of
    [] -> pure ()
    [extension] -> fail $ mconcat
                     [ "Generating Persistent entities now requires the "
                     , show extension
                     , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n"
                     , extensionToPragma extension
                     ]
    extensions -> fail $ mconcat
                    [ "Generating Persistent entities now requires the following language extensions:\n\n"
                    , List.intercalate "\n" (fmap show extensions)
                    , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"
                    , List.intercalate "\n" (fmap extensionToPragma extensions)
                    ]

  where
    extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}"

-- | creates a TH Name for use in the ToJSON instance
fieldToJSONValName :: UnboundFieldDef -> Q Name
fieldToJSONValName =
    newName . T.unpack . unFieldNameHSForJSON . 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 = fixTypeUnderscore . unFieldNameHS
  where
    fixTypeUnderscore = \case
        "type" -> "type_"
        name -> name

entityDefConK :: UnboundEntityDef -> Kind
entityDefConK = conK . mkEntityDefName

entityDefConT :: UnboundEntityDef -> Q Type
entityDefConT = pure . entityDefConK

entityDefConE :: UnboundEntityDef -> Exp
entityDefConE = ConE . 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 mps entDef fieldName =
    mkRecordName mps mUnderscore (entityHaskell (unboundEntityDef entDef)) fieldName
  where
    mUnderscore
        | mpsGenerateLenses mps = Just "_"
        | otherwise = Nothing

-- | as above, only takes a `FieldDef`
fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName mps entDef fieldDef =
    fieldNameToRecordName mps entDef (unboundFieldNameHS 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 mps entDef fieldDef =
    mkRecordName mps Nothing (entityHaskell (unboundEntityDef entDef)) (unboundFieldNameHS fieldDef)

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

    entityNameText :: Text
    entityNameText =
      unEntityNameHS entNameHS

    fieldNameText :: Text
    fieldNameText =
        unFieldNameHS fieldNameHS

    avoidKeyword :: Text -> Text
    avoidKeyword name = if name `Set.member` haskellKeywords then mpsAvoidHsKeyword mps name else name

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

-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name]
mkEntityDefDeriveNames mps entDef =
    let
        entityInstances =
            mkName . T.unpack <$> entityDerives (unboundEntityDef entDef)
        additionalInstances =
            filter (`notElem` entityInstances) $ mpsDeriveInstances mps
     in
        entityInstances <> additionalInstances

-- | Make a TH Name for the EntityDef's Haskell type
mkEntityNameHSName :: EntityNameHS -> Name
mkEntityNameHSName =
    mkName . T.unpack . unEntityNameHS

-- | As above only taking an `EntityDef`
mkEntityDefName :: UnboundEntityDef -> Name
mkEntityDefName =
    mkEntityNameHSName . entityHaskell . unboundEntityDef

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

mkEntityNameHSGenericName :: EntityNameHS -> Name
mkEntityNameHSGenericName name =
    mkName $ T.unpack (unEntityNameHS name <> "Generic")

-- needs:
--
-- * entityHaskell
--     * field on EntityDef
-- * fieldHaskell
--     * field on FieldDef
--
sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName mps entDef unboundFieldDef =
    mkName $ T.unpack name
  where
    name
        | mpsPrefixFields mps = modifiedName ++ "Sum"
        | otherwise           = fieldName ++ "Sum"
    fieldNameHS =
        unboundFieldNameHS unboundFieldDef
    modifiedName =
        mpsConstraintLabelModifier mps entityName fieldName
    entityName =
        unEntityNameHS $ getUnboundEntityNameHS entDef
    fieldName =
        upperFirst $ unFieldNameHS fieldNameHS

-- | Turn a ConstraintName into a TH Name
mkConstraintName :: ConstraintNameHS -> Name
mkConstraintName (ConstraintNameHS name) =
    mkName (T.unpack name)

keyIdName :: UnboundEntityDef -> Name
keyIdName = mkName . T.unpack . keyIdText

keyIdText :: UnboundEntityDef -> Text
keyIdText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) `mappend` "Id"

unKeyName :: UnboundEntityDef -> Name
unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef

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

backendT :: Type
backendT = VarT backendName

backendName :: Name
backendName = mkName "backend"

-- needs:
--
-- * keyText
--     * entityNameHaskell
--  * fields
--      * fieldHaskell
--
-- keyConName :: EntityNameHS -> [FieldHaskell] -> Name
keyConName :: UnboundEntityDef -> Name
keyConName entDef =
    keyConName'
        (getUnboundEntityNameHS entDef)
        (unboundFieldNameHS <$> unboundEntityFields (entDef))


keyConName' :: EntityNameHS -> [FieldNameHS] -> Name
keyConName' entName entFields = mkName $ T.unpack $ resolveConflict $ keyText' entName
  where
    resolveConflict kn = if conflict then kn `mappend` "'" else kn
    conflict = any (== FieldNameHS "key") entFields

-- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp
keyConExp :: UnboundEntityDef -> Exp
keyConExp ed = ConE $ keyConName ed

keyText :: UnboundEntityDef -> Text
keyText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) ++ "Key"

keyText' :: EntityNameHS -> Text
keyText' entName = unEntityNameHS entName ++ "Key"

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

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

filterConName'
    :: MkPersistSettings
    -> EntityNameHS
    -> FieldNameHS
    -> Name
filterConName' mps entity field = mkName $ T.unpack name
    where
        name
            | field == FieldNameHS "Id" = entityName ++ fieldName
            | mpsPrefixFields mps       = modifiedName
            | otherwise                 = fieldName

        modifiedName = mpsConstraintLabelModifier mps entityName fieldName
        entityName = unEntityNameHS entity
        fieldName = upperFirst $ unFieldNameHS 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 = do
    instances <- reifyInstances ''PersistEntity [VarT (mkName "a")]
    let
        types =
            mapMaybe getDecType instances
        getDecType dec =
            case dec of
                InstanceD _moverlap [] typ _decs ->
                    stripPersistEntity typ
                _ ->
                    Nothing
        stripPersistEntity typ =
            case typ of
                AppT (ConT tyName) t | tyName == ''PersistEntity ->
                    Just t
                _ ->
                    Nothing

    fmap ListE $
        forM types $ \typ -> do
            [e| entityDef (Proxy :: Proxy $(pure typ)) |]

setNull :: NonEmpty UnboundFieldDef -> Bool
setNull (fd :| fds) =
    let
        nullSetting =
            isNull fd
        isNull =
            (NotNullable /=) . isUnboundFieldNullable
    in
        if all ((nullSetting ==) . isNull) fds
        then nullSetting
        else error $
            "foreign key columns must all be nullable or non-nullable"
           ++ show (fmap (unFieldNameHS . unboundFieldNameHS) (fd:fds))