{-# 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.
module Database.Persist.TH
    ( -- * Parse entity defs
      persistWith
    , persistUpperCase
    , persistLowerCase
    , persistFileWith
    , persistManyFileWith
      -- * Turn @EntityDef@s into types
    , mkPersist
    , mkPersistWith
    , MkPersistSettings
    , mpsBackend
    , mpsGeneric
    , mpsPrefixFields
    , mpsFieldLabelModifier
    , mpsConstraintLabelModifier
    , mpsEntityJSON
    , mpsGenerateLenses
    , mpsDeriveInstances
    , EntityJSON(..)
    , mkPersistSettings
    , sqlSettings
    -- ** Implicit ID Columns
    , ImplicitIdDef
    , setImplicitIdDef
      -- * Various other TH functions
    , mkMigrate
    , migrateModels
    , discoverEntities
    , mkSave
    , mkDeleteCascade
    , 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(parseJSON)
       , ToJSON(toJSON)
       , Value(Object)
       , eitherDecodeStrict'
       , object
       , (.:)
       , (.:?)
       , (.=)
       )
#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 (toList)
import qualified Data.Set as Set
import Language.Haskell.TH.Lib
       (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
import Web.PathPieces (PathPiece(..))

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

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

#if MIN_VERSION_template_haskell(2,18,0)
conp :: Name -> [Pat] -> Pat
conp name pats = ConP name [] pats
#else
conp :: Name -> [Pat] -> Pat
conp = Name -> [Pat] -> Pat
ConP
#endif

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

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

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

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

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

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

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

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


-- | Calls 'parse' to Quasi.parse individual entities in isolation
-- afterwards, sets references to other entities
--
-- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@
-- instead of @['EntityDef']@.
--
-- @since 2.5.3
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps Text
s = [UnboundEntityDef] -> Q Exp
forall t. Lift t => t -> Q Exp
lift ([UnboundEntityDef] -> Q Exp) -> [UnboundEntityDef] -> Q Exp
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [UnboundEntityDef]
parse PersistSettings
ps Text
s

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

stripId :: FieldType -> Maybe Text
stripId :: FieldType -> Maybe Text
stripId (FTTypeCon Maybe Text
Nothing Text
t) = Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
t
stripId FieldType
_ = Maybe Text
forall a. Maybe a
Nothing

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

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

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

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

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

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

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

extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
fieldDef = do
    EntityNameHS
refName <- UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference UnboundFieldDef
fieldDef
    UnboundEntityDef
ent <- EntityNameHS -> EntityMap -> Maybe UnboundEntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
refName EntityMap
entityMap
    EntityNameHS -> Maybe EntityNameHS
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EntityNameHS -> Maybe EntityNameHS)
-> EntityNameHS -> Maybe EntityNameHS
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS) -> EntityDef -> EntityNameHS
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent

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

guessReference :: FieldType -> Maybe EntityNameHS
guessReference :: FieldType -> Maybe EntityNameHS
guessReference FieldType
ft =
    case FieldType
ft of
        FTTypeCon Maybe Text
Nothing (Text -> Text -> Maybe Text
T.stripSuffix Text
"Id" -> Just Text
tableName) ->
            EntityNameHS -> Maybe EntityNameHS
forall a. a -> Maybe a
Just (Text -> EntityNameHS
EntityNameHS Text
tableName)
        FTApp (FTTypeCon Maybe Text
Nothing Text
"Key") (FTTypeCon Maybe Text
Nothing Text
tableName) ->
            EntityNameHS -> Maybe EntityNameHS
forall a. a -> Maybe a
Just (Text -> EntityNameHS
EntityNameHS Text
tableName)
        FieldType
_ ->
            Maybe EntityNameHS
forall a. Maybe a
Nothing

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

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

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

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

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

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

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

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

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

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


type EmbedEntityMap = M.Map EntityNameHS ()

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

lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity :: Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity Map EntityNameHS a
allEntities FieldDef
field = do
    EntityNameHS
entName <- Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldType -> Maybe Text
stripId (FieldDef -> FieldType
fieldType FieldDef
field)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (EntityNameHS -> Map EntityNameHS a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member EntityNameHS
entName Map EntityNameHS a
allEntities) -- check entity name exists in embed fmap
    EntityNameHS -> Maybe EntityNameHS
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntityNameHS
entName

type EntityMap = M.Map EntityNameHS UnboundEntityDef

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

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

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

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

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

-- | Create data types and appropriate 'PersistEntity' instances for the given
-- 'EntityDef's. Works well with the persist quasi-quoter.
mkPersist
    :: MkPersistSettings
    -> [UnboundEntityDef]
    -> Q [Dec]
mkPersist :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
mkPersist MkPersistSettings
mps = MkPersistSettings -> [EntityDef] -> [UnboundEntityDef] -> Q [Dec]
mkPersistWith MkPersistSettings
mps []

-- | Like '
--
-- @since 2.13.0.0
mkPersistWith
    :: MkPersistSettings
    -> [EntityDef]
    -> [UnboundEntityDef]
    -> Q [Dec]
mkPersistWith :: MkPersistSettings -> [EntityDef] -> [UnboundEntityDef] -> Q [Dec]
mkPersistWith MkPersistSettings
mps [EntityDef]
preexistingEntities [UnboundEntityDef]
ents' = do
    let
        (EmbedEntityMap
embedEntityMap, [UnboundEntityDef]
predefs) =
            [EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
preprocessUnboundDefs [EntityDef]
preexistingEntities [UnboundEntityDef]
ents'
        allEnts :: [UnboundEntityDef]
allEnts =
            [EntityDef] -> [UnboundEntityDef] -> [UnboundEntityDef]
embedEntityDefs [EntityDef]
preexistingEntities
            ([UnboundEntityDef] -> [UnboundEntityDef])
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> UnboundEntityDef)
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields MkPersistSettings
mps)
            ([UnboundEntityDef] -> [UnboundEntityDef])
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> a -> b
$ [UnboundEntityDef]
predefs
        entityMap :: EntityMap
entityMap =
            [UnboundEntityDef] -> EntityMap
constructEntityMap [UnboundEntityDef]
allEnts
        preexistingSet :: Set EntityNameHS
preexistingSet =
            [EntityNameHS] -> Set EntityNameHS
forall a. Ord a => [a] -> Set a
Set.fromList ([EntityNameHS] -> Set EntityNameHS)
-> [EntityNameHS] -> Set EntityNameHS
forall a b. (a -> b) -> a -> b
$ (EntityDef -> EntityNameHS) -> [EntityDef] -> [EntityNameHS]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> EntityNameHS
getEntityHaskellName [EntityDef]
preexistingEntities
        newEnts :: [UnboundEntityDef]
newEnts =
            (UnboundEntityDef -> Bool)
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a. (a -> Bool) -> [a] -> [a]
filter
                (\UnboundEntityDef
e -> UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
e EntityNameHS -> Set EntityNameHS -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set EntityNameHS
preexistingSet)
                [UnboundEntityDef]
allEnts
    [UnboundEntityDef]
ents <- (UnboundEntityDef -> Q Bool)
-> [UnboundEntityDef] -> Q [UnboundEntityDef]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM UnboundEntityDef -> Q Bool
shouldGenerateCode [UnboundEntityDef]
newEnts
    [[Extension]] -> Q ()
requireExtensions
        [ [Extension
TypeFamilies], [Extension
GADTs, Extension
ExistentialQuantification]
        , [Extension
DerivingStrategies], [Extension
GeneralizedNewtypeDeriving], [Extension
StandaloneDeriving]
        , [Extension
UndecidableInstances], [Extension
DataKinds], [Extension
FlexibleInstances]
        ]
    [Dec]
persistFieldDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
entityDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (EmbedEntityMap
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
forall a.
Map EntityNameHS a
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkEntity EmbedEntityMap
embedEntityMap EntityMap
entityMap MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
jsonDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
uniqueKeyInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
symbolToFieldInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkSymbolToFieldInstances MkPersistSettings
mps EntityMap
entityMap) [UnboundEntityDef]
ents
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat
        [ [Dec]
persistFieldDecs
        , [Dec]
entityDecs
        , [Dec]
jsonDecs
        , [Dec]
uniqueKeyInstances
        , [Dec]
symbolToFieldInstances
        ]

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

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

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

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

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

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

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

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

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

-- | Create an @MkPersistSettings@ with default values.
mkPersistSettings
    :: Type -- ^ Value for 'mpsBackend'
    -> MkPersistSettings
mkPersistSettings :: Type -> MkPersistSettings
mkPersistSettings Type
backend = MkPersistSettings :: Type
-> Bool
-> Bool
-> (Text -> Text -> Text)
-> (Text -> Text -> Text)
-> Maybe EntityJSON
-> Bool
-> [Name]
-> ImplicitIdDef
-> MkPersistSettings
MkPersistSettings
    { mpsBackend :: Type
mpsBackend = Type
backend
    , mpsGeneric :: Bool
mpsGeneric = Bool
False
    , mpsPrefixFields :: Bool
mpsPrefixFields = Bool
True
    , mpsFieldLabelModifier :: Text -> Text -> Text
mpsFieldLabelModifier = Text -> Text -> Text
forall m. Monoid m => m -> m -> m
(++)
    , mpsConstraintLabelModifier :: Text -> Text -> Text
mpsConstraintLabelModifier = Text -> Text -> Text
forall m. Monoid m => m -> m -> m
(++)
    , mpsEntityJSON :: Maybe EntityJSON
mpsEntityJSON = EntityJSON -> Maybe EntityJSON
forall a. a -> Maybe a
Just EntityJSON :: Name -> Name -> EntityJSON
EntityJSON
        { entityToJSON :: Name
entityToJSON = 'entityIdToJSON
        , entityFromJSON :: Name
entityFromJSON = 'entityIdFromJSON
        }
    , mpsGenerateLenses :: Bool
mpsGenerateLenses = Bool
False
    , mpsDeriveInstances :: [Name]
mpsDeriveInstances = []
    , mpsImplicitIdDef :: ImplicitIdDef
mpsImplicitIdDef =
        ImplicitIdDef
autoIncrementingInteger
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    nullErrMsg :: String
nullErrMsg =
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"Error:  By default we disallow NULLables in an uniqueness "
              , String
"constraint.  The semantics of how NULL interacts with those "
              , String
"constraints is non-trivial:  two NULL values are not "
              , String
"considered equal for the purposes of an uniqueness "
              , String
"constraint.  If you understand this feature, it is possible "
              , String
"to use it your advantage.    *** Use a \"!force\" attribute "
              , String
"on the end of the line that defines your uniqueness "
              , String
"constraint in order to disable this check. ***" ]

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

    -- TODO: if we keep mpsGeneric, this needs to check 'mpsGeneric' and then
    -- append Generic to the model name, probably
    _removeIdFromTypeSuffix :: Name -> Type
    _removeIdFromTypeSuffix :: Name -> Type
_removeIdFromTypeSuffix oldName :: Name
oldName@(Name (OccName String
nm) NameFlavour
nameFlavor) =
        case Text -> Text -> Maybe Text
stripSuffix Text
"Id" (String -> Text
T.pack String
nm) of
            Maybe Text
Nothing ->
                Name -> Type
ConT Name
oldName
            Just Text
name ->
                Name -> Type
ConT ''Key
                Type -> Type -> Type
`AppT` do
                    Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ OccName -> NameFlavour -> Name
Name (String -> OccName
OccName (Text -> String
T.unpack Text
name)) NameFlavour
nameFlavor

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

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

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

-- | TODO:
--
-- if we keep mpsGeneric
-- then
--      let's make this fully qualify the generic name
-- else
--      let's delete it
genericDataType
    :: MkPersistSettings
    -> EntityNameHS
    -> Type -- ^ backend
    -> Type
genericDataType :: MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
name Type
backend
    | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
        Name -> Type
ConT (EntityNameHS -> Name
mkEntityNameHSGenericName EntityNameHS
name) Type -> Type -> Type
`AppT` Type
backend
    | Bool
otherwise =
        Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Name
mkEntityNameHSName EntityNameHS
name

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

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

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

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

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

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

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

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

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


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

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

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

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

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

    toSumClause :: Exp -> Name -> Name -> Name -> UnboundFieldDef -> Clause
toSumClause Exp
lens' Name
keyVar Name
valName Name
xName UnboundFieldDef
fieldDef = [Pat] -> Exp -> Clause
normalClause
        [Name -> [Pat] -> Pat
conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) []]
        (Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getter Exp -> Exp -> Exp
`AppE` Exp
setter)
      where
        emptyMatch :: Match
emptyMatch = Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'error Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
"Tried to use fieldLens on a Sum type")) []
        getter :: Exp
getter = [Pat] -> Exp -> Exp
LamE
            [ Name -> [Pat] -> Pat
conp 'Entity [Pat
WildP, Name -> Pat
VarP Name
valName]
            ] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
valName)
            ([Match] -> Exp) -> [Match] -> Exp
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
conp (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) [Name -> Pat
VarP Name
xName]) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
xName) []

            -- FIXME It would be nice if the types expressed that the Field is
            -- a sum type and therefore could result in Maybe.
            Match -> [Match] -> [Match]
forall a. a -> [a] -> [a]
: if [UnboundFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then [Match
emptyMatch] else []
        setter :: Exp
setter = [Pat] -> Exp -> Exp
LamE
            [ Name -> [Pat] -> Pat
conp 'Entity [Name -> Pat
VarP Name
keyVar, Pat
WildP]
            , Name -> Pat
VarP Name
xName
            ]
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Entity Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
keyVar Exp -> Exp -> Exp
`AppE` (Name -> Exp
ConE (MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
xName)

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

    Q ()
requirePersistentExtensions

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

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

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

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

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

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

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

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

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

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

-- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the
-- QuasiQuoter produces for an implicit ID and
defaultIdType :: UnboundEntityDef -> Bool
defaultIdType :: UnboundEntityDef -> Bool
defaultIdType UnboundEntityDef
entDef =
    case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
        DefaultKey FieldNameDB
_ ->
            Bool
True
        PrimarySpec
_ ->
            Bool
False

keyFields :: MkPersistSettings -> UnboundEntityDef -> [(Name, Strict, Type)]
keyFields :: MkPersistSettings -> UnboundEntityDef -> [VarBangType]
keyFields MkPersistSettings
mps UnboundEntityDef
entDef =
    case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
        NaturalKey UnboundCompositeDef
ucd ->
            (FieldNameHS -> VarBangType) -> [FieldNameHS] -> [VarBangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldNameHS -> VarBangType
naturalKeyVar (UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd)
        DefaultKey FieldNameDB
_ ->
            VarBangType -> [VarBangType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarBangType -> [VarBangType])
-> (Type -> VarBangType) -> Type -> [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar (Type -> [VarBangType]) -> Type -> [VarBangType]
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> Type
getImplicitIdType MkPersistSettings
mps
        SurrogateKey UnboundIdDef
k ->
            VarBangType -> [VarBangType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarBangType -> [VarBangType])
-> (Type -> VarBangType) -> Type -> [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarBangType
idKeyVar (Type -> [VarBangType]) -> Type -> [VarBangType]
forall a b. (a -> b) -> a -> b
$ case UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
k of
                Maybe FieldType
Nothing ->
                    MkPersistSettings -> Type
getImplicitIdType MkPersistSettings
mps
                Just FieldType
ty ->
                    FieldType -> Type
ftToType FieldType
ty
  where
    unboundFieldDefs :: [UnboundFieldDef]
unboundFieldDefs =
        UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
    naturalKeyVar :: FieldNameHS -> VarBangType
naturalKeyVar FieldNameHS
fieldName =
        case FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
findField FieldNameHS
fieldName [UnboundFieldDef]
unboundFieldDefs of
            Maybe UnboundFieldDef
Nothing ->
                String -> VarBangType
forall a. HasCallStack => String -> a
error String
"column not defined on entity"
            Just UnboundFieldDef
unboundFieldDef ->
                ( MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
keyFieldName MkPersistSettings
mps UnboundEntityDef
entDef (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
unboundFieldDef)
                , Bang
notStrict
                , FieldType -> Type
ftToType (FieldType -> Type) -> FieldType -> Type
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
unboundFieldDef
                )

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

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

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

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

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

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

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

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

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

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

-- |  Render an error message based on the @tableName@ and @fieldName@ with
-- the provided message.
--
-- @since 2.8.2
fieldError :: Text -> Text -> Text -> Text
fieldError :: Text -> Text -> Text -> Text
fieldError Text
tableName Text
fieldName Text
err = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
    [ Text
"Couldn't parse field `"
    , Text
fieldName
    , Text
"` from table `"
    , Text
tableName
    , Text
"`. "
    , Text
err
    ]

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

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

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

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

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

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

    [Dec
keyFromRecordM'] <-
        case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
            NaturalKey UnboundCompositeDef
ucd -> do
                Name
recordName <- String -> Q Name
newName String
"record"
                let
                    keyCon :: Name
keyCon =
                        UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef
                    keyFields' :: [Name]
keyFields' =
                        MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef (FieldNameHS -> Name) -> [FieldNameHS] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols UnboundCompositeDef
ucd
                    constr :: Exp
constr =
                        (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                            Exp -> Exp -> Exp
AppE
                            (Name -> Exp
ConE Name
keyCon)
                            ([Exp] -> [Exp]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([Exp] -> [Exp]) -> [Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                                (\Name
n ->
                                    Name -> Exp
VarE Name
n Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
recordName
                                )
                                [Name]
keyFields'
                            )
                    keyFromRec :: Q Pat
keyFromRec = Name -> Q Pat
varP 'keyFromRecordM
                [d|
                    $(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr))
                    |]

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

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

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

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

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

-- | @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 :: EntityIdDef -> FieldDef
stripIdFieldImpl EntityIdDef
eid =
    case EntityIdDef
eid of
        EntityIdField FieldDef
fd -> FieldDef
fd
        EntityIdNaturalKey CompositeDef
cd ->
            case CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
cd of
                (FieldDef
x :| [FieldDef]
xs) ->
                    case [FieldDef]
xs of
                        [] ->
                            FieldDef
x
                        [FieldDef]
_ ->
                            FieldDef
dummyFieldDef
  where
    dummyFieldDef :: FieldDef
dummyFieldDef =
        FieldDef :: FieldNameHS
-> FieldNameDB
-> FieldType
-> SqlType
-> [FieldAttr]
-> Bool
-> ReferenceDef
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> Bool
-> FieldDef
FieldDef
            { fieldHaskell :: FieldNameHS
fieldHaskell =
                Text -> FieldNameHS
FieldNameHS Text
"Id"
            , fieldDB :: FieldNameDB
fieldDB =
                Text -> FieldNameDB
FieldNameDB Text
"__composite_key_no_id__"
            , fieldType :: FieldType
fieldType =
                Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
"__Composite_Key__"
            , fieldSqlType :: SqlType
fieldSqlType =
                Text -> SqlType
SqlOther Text
"Composite Key"
            , fieldAttrs :: [FieldAttr]
fieldAttrs =
                []
            , fieldStrict :: Bool
fieldStrict =
                Bool
False
            , fieldReference :: ReferenceDef
fieldReference =
                ReferenceDef
NoReference
            , fieldCascade :: FieldCascade
fieldCascade =
                FieldCascade
noCascade
            , fieldComments :: Maybe Text
fieldComments =
                Maybe Text
forall a. Maybe a
Nothing
            , fieldGenerated :: Maybe Text
fieldGenerated =
                Maybe Text
forall a. Maybe a
Nothing
            , fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn =
                Bool
False
            }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

mkDoE :: [Stmt] -> Exp
mkDoE stmts = DoE Nothing stmts

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

mkDoE :: [Stmt] -> Exp
mkDoE :: [Stmt] -> Exp
mkDoE = [Stmt] -> Exp
DoE

mkPlainTV
    :: Name
    -> TyVarBndr
mkPlainTV :: Name -> TyVarBndr
mkPlainTV = Name -> TyVarBndr
PlainTV

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

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

        Name
recordName <- String -> Q Name
newName String
"record_mkForeignKeysComposite"

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

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

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

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

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

    | Bool
otherwise =
        [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    constraintToField :: ConstraintNameHS -> FieldNameHS
constraintToField = Text -> FieldNameHS
FieldNameHS (Text -> FieldNameHS)
-> (ConstraintNameHS -> Text) -> ConstraintNameHS -> FieldNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintNameHS -> Text
unConstraintNameHS


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

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

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

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

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

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

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

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

-- | Apply the given list of functions to the same @EntityDef@s.
--
-- This function is useful for cases such as:
--
-- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|]
share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec]
share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec]
share [[a] -> Q [Dec]]
fs [a]
x = [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([a] -> Q [Dec]) -> Q [Dec]) -> [[a] -> Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([a] -> Q [Dec]) -> [a] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [a]
x) [[a] -> Q [Dec]]
fs

-- | Save the @EntityDef@s passed in under the given name.
--
-- This function was deprecated in @persistent-2.13.0.0@. It doesn't properly
-- fix foreign keys. Please refer to 'mkEntityDefList' for a replacement.
mkSave :: String -> [EntityDef] -> Q [Dec]
mkSave :: String -> [EntityDef] -> Q [Dec]
mkSave String
name' [EntityDef]
defs' = do
    let name :: Name
name = String -> Name
mkName String
name'
    Exp
defs <- [EntityDef] -> Q Exp
forall t. Lift t => t -> Q Exp
lift [EntityDef]
defs'
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Type -> Dec
SigD Name
name (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Type
ListT Type -> Type -> Type
`AppT` Name -> Type
ConT ''EntityDef
           , Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Exp -> Clause
normalClause [] Exp
defs]
           ]

{-# DEPRECATED mkSave "This function is broken. mkEntityDefList is a drop-in replacement that will properly handle foreign keys correctly." #-}

data Dep = Dep
    { Dep -> EntityNameHS
depTarget :: EntityNameHS
    , Dep -> EntityNameHS
depSourceTable :: EntityNameHS
    , Dep -> FieldNameHS
depSourceField :: FieldNameHS
    , Dep -> IsNullable
depSourceNull  :: IsNullable
    }

{-# DEPRECATED mkDeleteCascade "You can now set update and delete cascade behavior directly on the entity in the quasiquoter. This function and class are deprecated and will be removed in the next major ersion." #-}

-- | Generate a 'DeleteCascade' instance for the given @EntityDef@s.
--
-- This function is deprecated as of 2.13.0.0. You can now set cascade
-- behavior directly in the quasiquoter.
mkDeleteCascade :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
mkDeleteCascade :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
mkDeleteCascade MkPersistSettings
mps [UnboundEntityDef]
defs = do
    let deps :: [Dep]
deps = (UnboundEntityDef -> [Dep]) -> [UnboundEntityDef] -> [Dep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnboundEntityDef -> [Dep]
getDeps [UnboundEntityDef]
defs
    (UnboundEntityDef -> Q Dec) -> [UnboundEntityDef] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Dep] -> UnboundEntityDef -> Q Dec
go [Dep]
deps) [UnboundEntityDef]
defs
  where
    getDeps :: UnboundEntityDef -> [Dep]
    getDeps :: UnboundEntityDef -> [Dep]
getDeps UnboundEntityDef
def =
        (UnboundFieldDef -> [Dep]) -> [UnboundFieldDef] -> [Dep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnboundFieldDef -> [Dep]
getDeps' ([UnboundFieldDef] -> [Dep]) -> [UnboundFieldDef] -> [Dep]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs (UnboundEntityDef -> [UnboundFieldDef])
-> UnboundEntityDef -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> UnboundEntityDef
fixEntityDef UnboundEntityDef
def
      where
        getDeps' :: UnboundFieldDef -> [Dep]
        getDeps' :: UnboundFieldDef -> [Dep]
getDeps' UnboundFieldDef
field =
            case UnboundFieldDef -> Maybe EntityNameHS
guessFieldReference UnboundFieldDef
field of
                Just EntityNameHS
name ->
                    Dep -> [Dep]
forall (m :: * -> *) a. Monad m => a -> m a
return Dep :: EntityNameHS -> EntityNameHS -> FieldNameHS -> IsNullable -> Dep
Dep
                        { depTarget :: EntityNameHS
depTarget = EntityNameHS
name
                        , depSourceTable :: EntityNameHS
depSourceTable = EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)
                        , depSourceField :: FieldNameHS
depSourceField = UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
field
                        , depSourceNull :: IsNullable
depSourceNull  = UnboundFieldDef -> IsNullable
isUnboundFieldNullable UnboundFieldDef
field
                        }
                Maybe EntityNameHS
Nothing ->
                    []
    go :: [Dep] -> UnboundEntityDef -> Q Dec
    go :: [Dep] -> UnboundEntityDef -> Q Dec
go [Dep]
allDeps UnboundEntityDef
ued = do
        let name :: EntityNameHS
name = EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ued)
        let deps :: [Dep]
deps = (Dep -> Bool) -> [Dep] -> [Dep]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Dep
x -> Dep -> EntityNameHS
depTarget Dep
x EntityNameHS -> EntityNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== EntityNameHS
name) [Dep]
allDeps
        Name
key <- String -> Q Name
newName String
"key"
        let del :: Exp
del = Name -> Exp
VarE 'delete
        let dcw :: Exp
dcw = Name -> Exp
VarE 'deleteCascadeWhere
        Exp
just <- [|Just|]
        Exp
filt <- [|Filter|]
        Exp
eq <- [|Eq|]
        Exp
value <- [|FilterValue|]
        let mkStmt :: Dep -> Stmt
            mkStmt :: Dep -> Stmt
mkStmt Dep
dep = Exp -> Stmt
NoBindS
                (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp
dcw Exp -> Exp -> Exp
`AppE`
                  [Exp] -> Exp
ListE
                    [ Exp
filt Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
filtName
                           Exp -> Exp -> Exp
`AppE` (Exp
value Exp -> Exp -> Exp
`AppE` IsNullable -> Exp
val (Dep -> IsNullable
depSourceNull Dep
dep))
                           Exp -> Exp -> Exp
`AppE` Exp
eq
                    ]
              where
                filtName :: Name
filtName = MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps (Dep -> EntityNameHS
depSourceTable Dep
dep) (Dep -> FieldNameHS
depSourceField Dep
dep)
                val :: IsNullable -> Exp
val (Nullable WhyNullable
ByMaybeAttr) = Exp
just Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
key
                val IsNullable
_                      =             Name -> Exp
VarE Name
key

        let stmts :: [Stmt]
            stmts :: [Stmt]
stmts = (Dep -> Stmt) -> [Dep] -> [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dep -> Stmt
mkStmt [Dep]
deps [Stmt] -> [Stmt] -> [Stmt]
forall m. Monoid m => m -> m -> m
`mappend`
                    [Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp
del Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
key]

        let entityT :: Type
entityT = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
name Type
backendT

        Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
            [Type] -> Type -> [Dec] -> Dec
instanceD
            [ Name -> [Type] -> Type
mkClassP ''PersistQuery [Type
backendT]
            , Type -> Type -> Type
mkEqualP (Name -> Type
ConT ''PersistEntityBackend Type -> Type -> Type
`AppT` Type
entityT) (Name -> Type
ConT ''BaseBackend Type -> Type -> Type
`AppT` Type
backendT)
            ]
            (Name -> Type
ConT ''DeleteCascade Type -> Type -> Type
`AppT` Type
entityT Type -> Type -> Type
`AppT` Type
backendT)
            [ Name -> [Clause] -> Dec
FunD 'deleteCascade
                [[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
key] ([Stmt] -> Exp
mkDoE [Stmt]
stmts)]
            ]

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

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

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

    go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
    go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' [(FieldNameHS, Name)]
xs Exp
front FieldNameHS
col =
        let Just Name
col' = FieldNameHS -> [(FieldNameHS, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FieldNameHS
col [(FieldNameHS, Name)]
xs
         in Exp
front Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
col'

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

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

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

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

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

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

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

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

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

-- Ent
--   fieldName FieldType
--
-- forall . typ ~ FieldType => EntFieldName
--
-- EntFieldName = FieldDef ....
--
-- Field Def Accessors Required:
mkField :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UnboundFieldDef -> Q EntityFieldTH
mkField :: MkPersistSettings
-> EntityMap
-> UnboundEntityDef
-> UnboundFieldDef
-> Q EntityFieldTH
mkField MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
et UnboundFieldDef
fieldDef = do
    let
        con :: Con
con =
            [TyVarBndr] -> [Type] -> Con -> Con
ForallC
                []
                [Type -> Type -> Type
mkEqualP (Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ") Type
fieldT]
                (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC Name
name []
        fieldT :: Type
fieldT =
            MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing
    Exp
bod <- UnboundEntityDef -> FieldNameHS -> Q Exp
mkLookupEntityField UnboundEntityDef
et (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)
    let cla :: Clause
cla = [Pat] -> Exp -> Clause
normalClause
                [Name -> [Pat] -> Pat
conp Name
name []]
                Exp
bod
    EntityFieldTH -> Q EntityFieldTH
forall (m :: * -> *) a. Monad m => a -> m a
return (EntityFieldTH -> Q EntityFieldTH)
-> EntityFieldTH -> Q EntityFieldTH
forall a b. (a -> b) -> a -> b
$ Con -> Clause -> EntityFieldTH
EntityFieldTH Con
con Clause
cla
  where
    name :: Name
name = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
filterConName MkPersistSettings
mps UnboundEntityDef
et UnboundFieldDef
fieldDef

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

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

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

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

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

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

mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON MkPersistSettings
_ UnboundEntityDef
def | (Text
"json" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` EntityDef -> [Text]
entityAttrs (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def)) = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkJSON MkPersistSettings
mps (UnboundEntityDef -> UnboundEntityDef
fixEntityDef -> UnboundEntityDef
def) = do
    [[Extension]] -> Q ()
requireExtensions [[Extension
FlexibleInstances]]
    Exp
pureE <- [|pure|]
    Exp
apE' <- [|(<*>)|]
#if MIN_VERSION_aeson(2,0,0)
    Exp
toKeyE <- [|Key.fromString|]
#else
    toKeyE <- [|pack|]
#endif
    Exp
dotEqualE <- [|(.=)|]
    Exp
dotColonE <- [|(.:)|]
    Exp
dotColonQE <- [|(.:?)|]
    Exp
objectE <- [|object|]
    Exp
withObjectE <- [|withObject|]
    Name
obj <- String -> Q Name
newName String
"obj"
    let
        fields :: [UnboundFieldDef]
fields =
            UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
def

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

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

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

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

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

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

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

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

-- | Check that all of Persistent's required extensions are enabled, or else fail compilation
--
-- This function should be called before any code that depends on one of the required extensions being enabled.
requirePersistentExtensions :: Q ()
requirePersistentExtensions :: Q ()
requirePersistentExtensions = [[Extension]] -> Q ()
requireExtensions [[Extension]]
requiredExtensions
  where
    requiredExtensions :: [[Extension]]
requiredExtensions = (Extension -> [Extension]) -> [Extension] -> [[Extension]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> [Extension]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Extension
DerivingStrategies
        , Extension
GeneralizedNewtypeDeriving
        , Extension
StandaloneDeriving
        , Extension
UndecidableInstances
        , Extension
MultiParamTypeClasses
        ]

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

        let fieldNameT :: Q Type
            fieldNameT :: Q Type
fieldNameT =
                TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> TyLitQ
strTyLit
                    (String -> TyLitQ) -> String -> TyLitQ
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall p. (Eq p, IsString p) => p -> p
lowerFirstIfId
                    (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldHaskellName

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

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

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

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

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

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

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

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

-- | This special-cases "type_" and strips out its underscore. When
-- used for JSON serialization and deserialization, it works around
-- <https://github.com/yesodweb/persistent/issues/412>
unFieldNameHSForJSON :: FieldNameHS -> Text
unFieldNameHSForJSON :: FieldNameHS -> Text
unFieldNameHSForJSON = Text -> Text
fixTypeUnderscore (Text -> Text) -> (FieldNameHS -> Text) -> FieldNameHS -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS
  where
    fixTypeUnderscore :: Text -> Text
fixTypeUnderscore = \case
        Text
"type" -> Text
"type_"
        Text
name -> Text
name

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

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

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

-- | creates a TH Name for an entity's field, based on the entity
-- name and the field name, so for example:
--
-- Customer
--   name Text
--
-- This would generate `customerName` as a TH Name
fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef FieldNameHS
fieldName =
    MkPersistSettings
-> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
mkRecordName MkPersistSettings
mps Maybe Text
mUnderscore (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)) FieldNameHS
fieldName
  where
    mUnderscore :: Maybe Text
mUnderscore
        | MkPersistSettings -> Bool
mpsGenerateLenses MkPersistSettings
mps = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"_"
        | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

-- | as above, only takes a `FieldDef`
fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef =
    MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)

-- | creates a TH Name for a lens on an entity's field, based on the entity
-- name and the field name, so as above but for the Lens
--
-- Customer
--   name Text
--
-- Generates a lens `customerName` when `mpsGenerateLenses` is true
-- while `fieldNameToRecordName` generates a prefixed function
-- `_customerName`
mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName MkPersistSettings
mps UnboundEntityDef
entDef UnboundFieldDef
fieldDef =
    MkPersistSettings
-> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
mkRecordName MkPersistSettings
mps Maybe Text
forall a. Maybe a
Nothing (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef)) (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fieldDef)

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

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

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

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

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

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

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

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

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

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

keyIdName :: UnboundEntityDef -> Name
keyIdName :: UnboundEntityDef -> Name
keyIdName = String -> Name
mkName (String -> Name)
-> (UnboundEntityDef -> String) -> UnboundEntityDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (UnboundEntityDef -> Text) -> UnboundEntityDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Text
keyIdText

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

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

unKeyExp :: UnboundEntityDef -> Exp
unKeyExp :: UnboundEntityDef -> Exp
unKeyExp = Name -> Exp
VarE (Name -> Exp)
-> (UnboundEntityDef -> Name) -> UnboundEntityDef -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> Name
unKeyName

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

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

-- needs:
--
-- * keyText
--     * entityNameHaskell
--  * fields
--      * fieldHaskell
--
-- keyConName :: EntityNameHS -> [FieldHaskell] -> Name
keyConName :: UnboundEntityDef -> Name
keyConName :: UnboundEntityDef -> Name
keyConName UnboundEntityDef
entDef =
    EntityNameHS -> [FieldNameHS] -> Name
keyConName'
        (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef)
        (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS (UnboundFieldDef -> FieldNameHS)
-> [UnboundFieldDef] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields (UnboundEntityDef
entDef))


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

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

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

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

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

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

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

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

-- | Splice in a list of all 'EntityDef' in scope. This is useful when running
-- 'mkPersist' to ensure that all entity definitions are available for setting
-- foreign keys, and for performing migrations with all entities available.
--
-- 'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to
-- account for entities defined elsewhere, you'll @mappend $(discoverEntities)@.
--
-- For example,
--
-- @
-- share
--   [ mkPersistWith sqlSettings $(discoverEntities)
--   ]
--   [persistLowerCase| ... |]
-- @
--
-- Likewise, to run migrations with all entity instances in scope, you'd write:
--
-- @
-- migrateAll = migrateModels $(discoverEntities)
-- @
--
-- Note that there is some odd behavior with Template Haskell and splicing
-- groups. If you call 'discoverEntities' in the same module that defines
-- 'PersistEntity' instances, you need to ensure they are in different top-level
-- binding groups. You can write @$(pure [])@ at the top level to do this.
--
-- @
-- -- Foo and Bar both export an instance of PersistEntity
-- import Foo
-- import Bar
--
-- -- Since Foo and Bar are both imported, discoverEntities can find them here.
-- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase|
--   User
--     name Text
--     age  Int
--   |]
--
-- -- onlyFooBar is defined in the same 'top level group' as the above generated
-- -- instance for User, so it isn't present in this list.
-- onlyFooBar :: [EntityDef]
-- onlyFooBar = $(discoverEntities)
--
-- -- We can manually create a new binding group with this, which splices an
-- -- empty list of declarations in.
-- $(pure [])
--
-- -- fooBarUser is able to see the 'User' instance.
-- fooBarUser :: [EntityDef]
-- fooBarUser = $(discoverEntities)
-- @
--
-- @since 2.13.0.0
discoverEntities :: Q Exp
discoverEntities :: Q Exp
discoverEntities = do
    [Dec]
instances <- Name -> [Type] -> Q [Dec]
reifyInstances ''PersistEntity [Name -> Type
VarT (String -> Name
mkName String
"a")]
    let
        types :: [Type]
types =
            (Dec -> Maybe Type) -> [Dec] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe Type
getDecType [Dec]
instances
        getDecType :: Dec -> Maybe Type
getDecType Dec
dec =
            case Dec
dec of
                InstanceD Maybe Overlap
_moverlap [] Type
typ [Dec]
_decs ->
                    Type -> Maybe Type
stripPersistEntity Type
typ
                Dec
_ ->
                    Maybe Type
forall a. Maybe a
Nothing
        stripPersistEntity :: Type -> Maybe Type
stripPersistEntity Type
typ =
            case Type
typ of
                AppT (ConT Name
tyName) Type
t | Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''PersistEntity ->
                    Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
                Type
_ ->
                    Maybe Type
forall a. Maybe a
Nothing

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

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