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

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

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

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

import Control.Monad
import Data.Aeson
       ( FromJSON(..)
       , ToJSON(..)
       , eitherDecodeStrict'
       , object
       , withObject
       , (.:)
       , (.:?)
       , (.=)
       )
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Key
#endif
import qualified Data.ByteString as BS
import Data.Char (toLower, toUpper)
import Data.Coerce
import Data.Data (Data)
import Data.Either
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.Ix (Ix)
import Data.List (foldl')
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import GHC.TypeLits
import Instances.TH.Lift ()
    -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text`
    -- instance on pre-1.2.4 versions of `text`
import Data.Foldable (asum, toList)
import qualified Data.Set as Set
import Language.Haskell.TH.Lib
       (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT)
#if MIN_VERSION_template_haskell(2,21,0)
import Language.Haskell.TH.Lib (defaultBndrFlag)
#endif
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
import Web.PathPieces (PathPiece(..))

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

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

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

-- | Converts a quasi-quoted syntax into a list of entity definitions, to be
-- used as input to the template haskell generation code (mkPersist).
persistWith :: PersistSettings -> QuasiQuoter
persistWith :: PersistSettings -> QuasiQuoter
persistWith PersistSettings
ps = QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp =
        PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps (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
-- '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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO Text -> Q Text
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> (String -> IO Text) -> String -> Q Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
getFileContents) [String]
fps
    let s :: Text
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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (IO ByteString -> IO Text)
-> (String -> IO ByteString) -> String -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile

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

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


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

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

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

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

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

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

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

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

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

extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
extractForeignRef EntityMap
entityMap UnboundFieldDef
fieldDef = do
    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 a. a -> Maybe a
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 =
    Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FieldType -> Maybe Text
guessReferenceText (FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just FieldType
ft)
  where
    checkIdSuffix :: Text -> Maybe Text
checkIdSuffix =
        Text -> Text -> Maybe Text
T.stripSuffix Text
"Id"
    guessReferenceText :: Maybe FieldType -> Maybe Text
guessReferenceText Maybe FieldType
mft =
        [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
            [ do
                FTTypeCon Maybe Text
_ (Text -> Maybe Text
checkIdSuffix -> Just Text
tableName) <- Maybe FieldType
mft
                Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
tableName
            , do
                FTApp (FTTypeCon Maybe Text
_ Text
"Key") (FTTypeCon Maybe Text
_ Text
tableName) <- Maybe FieldType
mft
                Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
tableName
            , do
                FTApp (FTTypeCon Maybe Text
_ Text
"Maybe") FieldType
next <- Maybe FieldType
mft
                Maybe FieldType -> Maybe Text
guessReferenceText (FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just FieldType
next)
            ]

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

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

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

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

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

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

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

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

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

data SqlTypeExp
    = SqlTypeExp FieldType
    | SqlType' SqlType
    | SqlTypeReference EntityNameHS
    deriving Int -> SqlTypeExp -> 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
$cshowsPrec :: Int -> SqlTypeExp -> ShowS
showsPrec :: Int -> SqlTypeExp -> ShowS
$cshow :: SqlTypeExp -> String
show :: SqlTypeExp -> String
$cshowList :: [SqlTypeExp] -> ShowS
showList :: [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 (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => SqlType -> m Exp
lift SqlType
t
        SqlTypeExp FieldType
ftype -> do
            let
                typ :: Type
typ = FieldType -> Type
ftToType FieldType
ftype
                mtyp :: Type
mtyp = Name -> Type
ConT ''Proxy Type -> Type -> Type
`AppT` Type
typ
                typedNothing :: Exp
typedNothing = Exp -> Type -> Exp
SigE (Name -> Exp
ConE 'Proxy) Type
mtyp
            Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'sqlType Exp -> Exp -> Exp
`AppE` Exp
typedNothing
        SqlTypeReference EntityNameHS
entNameHs -> do
            let
                entNameId :: Name
                entNameId :: Name
entNameId =
                    String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Id"

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


type EmbedEntityMap = M.Map EntityNameHS ()

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

lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity :: forall a. Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
lookupEmbedEntity Map EntityNameHS a
allEntities FieldDef
field = do
    let mfieldTy :: Maybe FieldType
mfieldTy = FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just (FieldType -> Maybe FieldType) -> FieldType -> Maybe FieldType
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
field
    EntityNameHS
entName <- Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS) -> Maybe Text -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ do
            FTTypeCon Maybe Text
_ Text
t <- Maybe FieldType
mfieldTy
            Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
t
        , do
            FTApp (FTTypeCon Maybe Text
_ Text
"Key") (FTTypeCon Maybe Text
_ Text
entName) <- Maybe FieldType
mfieldTy
            Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
entName
        , do
            FTApp (FTTypeCon Maybe Text
_ Text
"Maybe") (FTTypeCon Maybe Text
_ Text
t) <- Maybe FieldType
mfieldTy
            Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
t
        ]
    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 a. a -> Maybe a
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\UnboundEntityDef
ent -> (EntityDef -> EntityNameHS
entityHaskell (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent), UnboundEntityDef
ent))

data FTTypeConDescr = FTKeyCon Text
    deriving Int -> FTTypeConDescr -> 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
$cshowsPrec :: Int -> FTTypeConDescr -> ShowS
showsPrec :: Int -> FTTypeConDescr -> ShowS
$cshow :: FTTypeConDescr -> String
show :: FTTypeConDescr -> String
$cshowList :: [FTTypeConDescr] -> ShowS
showList :: [FTTypeConDescr] -> ShowS
Show

-- | Recurses through the 'FieldType'. Returns a 'Right' with the
-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of
-- a name and that name is present in the 'EmbedEntityMap' provided as
-- a first argument.
--
-- If the 'FieldType' represents a @Key something@, this returns a @'Left
-- ('Just' 'FTKeyCon')@.
--
-- If the 'FieldType' has a module qualified value, then it returns @'Left'
-- 'Nothing'@.
mEmbedded
    :: M.Map EntityNameHS a
    -> FieldType
    -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded :: forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
_ (FTTypeCon Just{} Text
_) =
    Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
ents (FTTypeCon Maybe Text
Nothing (Text -> EntityNameHS
EntityNameHS -> EntityNameHS
name)) =
    Either (Maybe FTTypeConDescr) EntityNameHS
-> (a -> Either (Maybe FTTypeConDescr) EntityNameHS)
-> Maybe a
-> Either (Maybe FTTypeConDescr) EntityNameHS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing) (\a
_ -> EntityNameHS -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. b -> Either a b
Right EntityNameHS
name) (Maybe a -> Either (Maybe FTTypeConDescr) EntityNameHS)
-> Maybe a -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Map EntityNameHS a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
name Map EntityNameHS a
ents
mEmbedded Map EntityNameHS a
_ (FTTypePromoted Text
_) =
    Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
ents (FTList FieldType
x) =
    Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
ents FieldType
x
mEmbedded Map EntityNameHS a
_ (FTApp (FTTypeCon Maybe Text
Nothing Text
"Key") (FTTypeCon Maybe Text
_ Text
a)) =
    Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left (Maybe FTTypeConDescr
 -> Either (Maybe FTTypeConDescr) EntityNameHS)
-> Maybe FTTypeConDescr
-> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. (a -> b) -> a -> b
$ FTTypeConDescr -> Maybe FTTypeConDescr
forall a. a -> Maybe a
Just (FTTypeConDescr -> Maybe FTTypeConDescr)
-> FTTypeConDescr -> Maybe FTTypeConDescr
forall a b. (a -> b) -> a -> b
$ Text -> FTTypeConDescr
FTKeyCon (Text -> FTTypeConDescr) -> Text -> FTTypeConDescr
forall a b. (a -> b) -> a -> b
$ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Id"
mEmbedded Map EntityNameHS a
_ (FTApp FieldType
_ FieldType
_) =
    Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS a
_ (FTLit FieldTypeLit
_) =
    Maybe FTTypeConDescr -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing

setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef
setEmbedField :: forall a.
EntityNameHS -> Map EntityNameHS a -> FieldDef -> FieldDef
setEmbedField EntityNameHS
entName Map EntityNameHS a
allEntities FieldDef
field =
    case FieldDef -> ReferenceDef
fieldReference FieldDef
field of
      ReferenceDef
NoReference ->
          ReferenceDef -> FieldDef -> FieldDef
setFieldReference ReferenceDef
ref FieldDef
field
      ReferenceDef
_ ->
          FieldDef
field
  where
    ref :: ReferenceDef
ref =
        case Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
forall a.
Map EntityNameHS a
-> FieldType -> Either (Maybe FTTypeConDescr) EntityNameHS
mEmbedded Map EntityNameHS a
allEntities (FieldDef -> FieldType
fieldType FieldDef
field) of
            Left Maybe FTTypeConDescr
_ -> ReferenceDef -> Maybe ReferenceDef -> ReferenceDef
forall a. a -> Maybe a -> a
fromMaybe ReferenceDef
NoReference (Maybe ReferenceDef -> ReferenceDef)
-> Maybe ReferenceDef -> ReferenceDef
forall a b. (a -> b) -> a -> b
$ do
                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 a. a -> Maybe a
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 = ref }

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

-- | Like 'mkPersist', but allows you to provide a @['EntityDef']@
-- representing the predefined entities. This function will include those
-- 'EntityDef' when looking for foreign key references.
--
-- You should use this if you intend on defining Persistent models in
-- multiple files.
--
-- Suppose we define a table @Foo@ which has no dependencies.
--
-- @
-- module DB.Foo where
--
--     'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'|
--         Foo
--            name    Text
--        |]
-- @
--
-- Then, we define a table @Bar@ which depends on @Foo@:
--
-- @
-- module DB.Bar where
--
--     import DB.Foo
--
--     'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'|
--         Bar
--             fooId  FooId
--      |]
-- @
--
-- Writing out the list of 'EntityDef' can be annoying. The
-- @$('discoverEntities')@ shortcut will work to reduce this boilerplate.
--
-- @
-- module DB.Quux where
--
--     import DB.Foo
--     import DB.Bar
--
--     'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'|
--         Quux
--             name     Text
--             fooId    FooId
--             barId    BarId
--      |]
-- @
--
-- @since 2.13.0.0
mkPersistWith
    :: MkPersistSettings
    -> [EntityDef]
    -> [UnboundEntityDef]
    -> Q [Dec]
mkPersistWith :: MkPersistSettings -> [EntityDef] -> [UnboundEntityDef] -> Q [Dec]
mkPersistWith MkPersistSettings
mps [EntityDef]
preexistingEntities [UnboundEntityDef]
ents' = do
    let
        (EmbedEntityMap
embedEntityMap, [UnboundEntityDef]
predefs) =
            [EntityDef]
-> [UnboundEntityDef] -> (EmbedEntityMap, [UnboundEntityDef])
preprocessUnboundDefs [EntityDef]
preexistingEntities [UnboundEntityDef]
ents'
        allEnts :: [UnboundEntityDef]
allEnts =
            [EntityDef] -> [UnboundEntityDef] -> [UnboundEntityDef]
embedEntityDefs [EntityDef]
preexistingEntities
            ([UnboundEntityDef] -> [UnboundEntityDef])
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> UnboundEntityDef)
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
setDefaultIdFields MkPersistSettings
mps)
            ([UnboundEntityDef] -> [UnboundEntityDef])
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> a -> b
$ [UnboundEntityDef]
predefs
        entityMap :: EntityMap
entityMap =
            [UnboundEntityDef] -> EntityMap
constructEntityMap [UnboundEntityDef]
allEnts
        preexistingSet :: Set EntityNameHS
preexistingSet =
            [EntityNameHS] -> Set EntityNameHS
forall a. Ord a => [a] -> Set a
Set.fromList ([EntityNameHS] -> Set EntityNameHS)
-> [EntityNameHS] -> Set EntityNameHS
forall a b. (a -> b) -> a -> b
$ (EntityDef -> EntityNameHS) -> [EntityDef] -> [EntityNameHS]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> EntityNameHS
getEntityHaskellName [EntityDef]
preexistingEntities
        newEnts :: [UnboundEntityDef]
newEnts =
            (UnboundEntityDef -> Bool)
-> [UnboundEntityDef] -> [UnboundEntityDef]
forall a. (a -> Bool) -> [a] -> [a]
filter
                (\UnboundEntityDef
e -> UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
e EntityNameHS -> Set EntityNameHS -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set EntityNameHS
preexistingSet)
                [UnboundEntityDef]
allEnts
    [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 a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
entityDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (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 a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkJSON MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
uniqueKeyInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkUniqueKeyInstances MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
safeToInsertInstances <- [[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
<$> (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkSafeToInsertInstance MkPersistSettings
mps) [UnboundEntityDef]
ents
    [Dec]
symbolToFieldInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (UnboundEntityDef -> Q [Dec]) -> [UnboundEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
mkSymbolToFieldInstances MkPersistSettings
mps EntityMap
entityMap) [UnboundEntityDef]
ents
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat
        [ [Dec]
persistFieldDecs
        , [Dec]
entityDecs
        , [Dec]
jsonDecs
        , [Dec]
uniqueKeyInstances
        , [Dec]
symbolToFieldInstances
        , [Dec]
safeToInsertInstances
        ]

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

        DefaultKey FieldNameDB
_ ->
            Q [Dec]
instanceOkay

  where
    typ :: Type
    typ :: Type
typ = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
ued) Type
backendT

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

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


-- we can't just use 'isInstance' because TH throws an error
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode :: UnboundEntityDef -> Q Bool
shouldGenerateCode UnboundEntityDef
ed = do
    Maybe Name
mtyp <- String -> Q (Maybe Name)
lookupTypeName String
entityName
    case Maybe Name
mtyp of
        Maybe Name
Nothing -> do
            Bool -> Q Bool
forall a. a -> Q a
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 a. a -> Q a
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 = f (unboundEntityDef ued) }

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

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

-- | Settings 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
mpsAvoidHsKeyword :: Text -> Text
    -- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords.
    --
    -- Default: suffix "_".
    --
    -- @since 2.14.6.0
    , MkPersistSettings -> Text -> Text -> Text
mpsConstraintLabelModifier :: Text -> Text -> Text
    -- ^ Customise the Constraint names using the entity and field name. The
    -- result should be a valid haskell type (start with an upper cased letter).
    --
    -- Default: appends entity and field
    --
    -- Note: this setting is ignored if mpsPrefixFields is set to False.
    --
    -- @since 2.11.0.0
    , MkPersistSettings -> Bool
mpsEntityHaddocks :: Bool
    -- ^ Generate Haddocks from entity documentation comments. Default: False.
    --
    -- @since 2.14.6.0
    , MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON :: Maybe EntityJSON
    -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's
    -- @Nothing@, no instances will be generated. Default:
    --
    -- @
    --  Just 'EntityJSON'
    --      { 'entityToJSON' = 'entityIdToJSON
    --      , 'entityFromJSON' = 'entityIdFromJSON
    --      }
    -- @
    , MkPersistSettings -> Bool
mpsGenerateLenses :: Bool
    -- ^ Instead of generating normal field accessors, generator lens-style
    -- accessors.
    --
    -- Default: False
    --
    -- @since 1.3.1
    , MkPersistSettings -> [Name]
mpsDeriveInstances :: [Name]
    -- ^ Automatically derive these typeclass instances for all record and key
    -- types.
    --
    -- Default: []
    --
    -- @since 2.8.1
    , MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef :: ImplicitIdDef
    -- ^ TODO: document
    --
    -- @since 2.13.0.0
    , MkPersistSettings -> Bool
mpsCamelCaseCompositeKeySelector :: Bool
    -- ^ Should we generate composite key accessors in the correct CamelCase style.
    --
    -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'False',
    -- then the field part of the accessor starts with the lowercase.
    -- This is a legacy style.
    --
    -- @
    -- data Key CompanyUser = CompanyUserKey
    --   { companyUserKeycompanyId :: CompanyId
    --   , companyUserKeyuserId :: UserId
    --   }
    -- @
    --
    -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'True',
    -- then field accessors are generated in CamelCase style.
    --
    -- @
    -- data Key CompanyUser = CompanyUserKey
    --   { companyUserKeyCompanyId :: CompanyId
    --   , companyUserKeyUserId :: UserId
    --   }
    -- @

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

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

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

getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType :: MkPersistSettings -> Type
getImplicitIdType = do
    ImplicitIdDef
idDef <- MkPersistSettings -> ImplicitIdDef
mpsImplicitIdDef
    Bool
isGeneric <- MkPersistSettings -> Bool
mpsGeneric
    Type
backendTy <- MkPersistSettings -> Type
mpsBackend
    Type -> MkPersistSettings -> Type
forall a. a -> MkPersistSettings -> a
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
    { mpsBackend :: Type
mpsBackend = Type
backend
    , mpsGeneric :: Bool
mpsGeneric = Bool
False
    , mpsPrefixFields :: Bool
mpsPrefixFields = Bool
True
    , mpsFieldLabelModifier :: Text -> Text -> Text
mpsFieldLabelModifier = Text -> Text -> Text
forall m. Monoid m => m -> m -> m
(++)
    , mpsAvoidHsKeyword :: Text -> Text
mpsAvoidHsKeyword = (Text -> Text -> Text
forall m. Monoid m => m -> m -> m
++ Text
"_")
    , mpsConstraintLabelModifier :: Text -> Text -> Text
mpsConstraintLabelModifier = Text -> Text -> Text
forall m. Monoid m => m -> m -> m
(++)
    , mpsEntityHaddocks :: Bool
mpsEntityHaddocks = Bool
False
    , mpsEntityJSON :: Maybe EntityJSON
mpsEntityJSON = EntityJSON -> Maybe EntityJSON
forall a. a -> Maybe a
Just EntityJSON
        { entityToJSON :: Name
entityToJSON = 'entityIdToJSON
        , entityFromJSON :: Name
entityFromJSON = 'entityIdFromJSON
        }
    , mpsGenerateLenses :: Bool
mpsGenerateLenses = Bool
False
    , mpsDeriveInstances :: [Name]
mpsDeriveInstances = []
    , mpsImplicitIdDef :: ImplicitIdDef
mpsImplicitIdDef =
        ImplicitIdDef
autoIncrementingInteger
    , mpsCamelCaseCompositeKeySelector :: Bool
mpsCamelCaseCompositeKeySelector = Bool
False
    }

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

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

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

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

    let ([Name]
stocks, [Name]
anyclasses) = [Either Name Name] -> ([Name], [Name])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((Name -> Either Name Name) -> [Name] -> [Either Name Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Either Name Name
stratFor [Name]
names)
    let stockDerives :: [DerivClause]
stockDerives = do
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
stocks))
            DerivClause -> [DerivClause]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
ConT [Name]
stocks))
        anyclassDerives :: [DerivClause]
anyclassDerives = do
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
anyclasses))
            DerivClause -> [DerivClause]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
AnyclassStrategy) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
ConT [Name]
anyclasses))
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DerivClause] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DerivClause]
anyclassDerives) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
        [[Extension]] -> Q ()
requireExtensions [[Extension
DeriveAnyClass]]
    let dec :: Dec
dec = [Type]
-> Name
-> [TyVarBndr ()]
-> 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)
#if MIN_VERSION_template_haskell(2,18,0)
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MkPersistSettings -> Bool
mpsEntityHaddocks MkPersistSettings
mps) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
        [(VarBangType, Maybe Text)]
-> ((VarBangType, Maybe Text) -> Q ()) -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(VarBangType, Maybe Text)]
cols (((VarBangType, Maybe Text) -> Q ()) -> Q ())
-> ((VarBangType, Maybe Text) -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \((Name
name, Bang
_, Type
_), Maybe Text
maybeComments) -> do
            case Maybe Text
maybeComments of
                Just Text
comment -> Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
                    DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
name) (Text -> String
unpack Text
comment)
                Maybe Text
Nothing -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        case EntityDef -> Maybe Text
entityComments (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
entDef) of
            Just Text
doc -> do
                Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
nameFinal) (Text -> String
unpack Text
doc)
            Maybe Text
_ -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif
    Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec

  where
    stratFor :: Name -> Either Name Name
stratFor Name
n =
        if Name
n Name -> Set Name -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set Name
stockClasses then
            Name -> Either Name Name
forall a b. a -> Either a b
Left Name
n
        else
            Name -> Either Name Name
forall a b. b -> Either a b
Right Name
n

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

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

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

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

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

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

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

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

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

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

-- | 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 a. a -> Maybe a
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 a. a -> Maybe a
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 a. a -> Q a
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 a. a -> Q a
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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
_removeIdFromTypeSuffix Maybe Name
mIdName

    _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String
    _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String
_fieldNameEndsWithId UnboundFieldDef
ufd = FieldType -> Maybe String
go (UnboundFieldDef -> FieldType
unboundFieldType UnboundFieldDef
ufd)
      where
        go :: FieldType -> Maybe String
go = \case
            FTTypeCon Maybe Text
mmodule Text
name -> do
                Text
a <- Text -> Text -> Maybe Text
stripSuffix Text
"Id" Text
name
                String -> Maybe String
forall a. a -> Maybe a
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Clause] -> Q [Clause]) -> [Q Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ (UnboundFieldDef -> Int -> Q Clause)
-> [UnboundFieldDef] -> [Int] -> [Q Clause]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith UnboundFieldDef -> Int -> Q Clause
goSum [UnboundFieldDef]
fields [Int
1..]
            else (Clause -> [Clause]) -> Q Clause -> Q [Clause]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Clause -> [Clause]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Q Clause
go
    Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD '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)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Q Name -> [Q Name]
forall a. Int -> a -> [a]
replicate Int
fieldCount (Q Name -> [Q Name]) -> Q Name -> [Q Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        let name :: 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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
xs
        Exp
sp <- [|toPersistValue|]
        let bod :: Exp
bod = [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE Exp
sp (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs
        Clause -> Q Clause
forall a. a -> Q a
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ed)

    goSum :: UnboundFieldDef -> Int -> Q Clause
    goSum :: UnboundFieldDef -> Int -> Q Clause
goSum UnboundFieldDef
fieldDef Int
idx = do
        let name :: Name
name = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
sumConstrName MkPersistSettings
mps UnboundEntityDef
ed UnboundFieldDef
fieldDef
        Exp
enull <- [|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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        Exp
sp <- [|toPersistValue|]
        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 a. a -> Q a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM UniqueDef -> Q Clause
forall {m :: * -> *}. Quote m => UniqueDef -> m Clause
go [UniqueDef]
pairs
    Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueToFieldNames ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [Clause] -> [Clause]
degen [Clause]
pairs'
  where
    go :: UniqueDef -> m Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ NonEmpty ForeignFieldDef
names [Text]
_) = do
        Exp
names' <- NonEmpty ForeignFieldDef -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => NonEmpty ForeignFieldDef -> m Exp
lift NonEmpty ForeignFieldDef
names
        Clause -> m Clause
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> m Clause) -> Clause -> m Clause
forall a b. (a -> b) -> a -> b
$
            [Pat] -> Exp -> Clause
normalClause
                [Name -> [(Name, Pat)] -> Pat
RecP (ConstraintNameHS -> Name
mkConstraintName ConstraintNameHS
constr) []]
                Exp
names'

mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues [UniqueDef]
pairs = do
    [Clause]
pairs' <- (UniqueDef -> Q Clause) -> [UniqueDef] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM UniqueDef -> Q Clause
go [UniqueDef]
pairs
    Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD '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)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Q Name -> ForeignFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> ForeignFieldDef -> Q Name)
-> Q Name -> ForeignFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x") NonEmpty ForeignFieldDef
names
        let pat :: 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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP ([Name] -> [Pat]) -> [Name] -> [Pat]
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> [Name]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
        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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE Exp
tpv (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) ([Name] -> [Exp]) -> [Name] -> [Exp]
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> [Name]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Name
xs
        Clause -> Q Clause
forall a. a -> Q a
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 :: forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft a -> c
_ (Right b
r) = b -> Either c b
forall a b. b -> Either a b
Right b
r
mapLeft a -> c
f (Left a
l)  = c -> Either c b
forall a b. a -> Either a b
Left (a -> c
f a
l)

-- needs:
--
-- * getEntityFields
--     * sumConstrName on field
-- * fromValues
-- * entityHaskell
-- * sumConstrName
-- * entityDefConE
--
--
mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
mkFromPersistValues MkPersistSettings
mps UnboundEntityDef
entDef
    | UnboundEntityDef -> Bool
unboundEntitySum UnboundEntityDef
entDef = do
        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 a. a -> Q a
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundFieldDef -> FieldNameHS
unboundFieldNameHS
        ([UnboundFieldDef] -> [FieldNameHS])
-> [UnboundFieldDef] -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ (UnboundFieldDef -> Bool) -> [UnboundFieldDef] -> [UnboundFieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter UnboundFieldDef -> Bool
isHaskellUnboundField
        ([UnboundFieldDef] -> [UnboundFieldDef])
-> [UnboundFieldDef] -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
entDef
  where
    entName :: Text
entName = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef
    mkClauses :: [UnboundFieldDef] -> [UnboundFieldDef] -> Q [Clause]
mkClauses [UnboundFieldDef]
_ [] = [Clause] -> Q [Clause]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    mkClauses [UnboundFieldDef]
before (UnboundFieldDef
field:[UnboundFieldDef]
after) = do
        Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        let null' :: Pat
null' = Name -> [Pat] -> Pat
conp 'PersistNull []
            pat :: Pat
pat = [Pat] -> Pat
ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ [[Pat]] -> [Pat]
forall a. Monoid a => [a] -> a
mconcat
                [ (UnboundFieldDef -> Pat) -> [UnboundFieldDef] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pat -> UnboundFieldDef -> Pat
forall a b. a -> b -> a
const Pat
null') [UnboundFieldDef]
before
                , [Name -> Pat
VarP Name
x]
                , (UnboundFieldDef -> Pat) -> [UnboundFieldDef] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pat -> UnboundFieldDef -> Pat
forall a b. a -> b -> a
const Pat
null') [UnboundFieldDef]
after
                ]
            constr :: 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 $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
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 a. a -> Q a
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 :: forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lensPTH s -> a
sa s -> b -> t
sbt a -> f b
afb s
s = (b -> t) -> f b -> f t
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s -> b -> t
sbt s
s) (a -> f b
afb (a -> f b) -> a -> f b
forall a b. (a -> b) -> a -> b
$ s -> a
sa s
s)

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

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

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

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

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

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

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

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

-- | declare the key type and associated instances
-- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field
mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
mkKeyTypeDec MkPersistSettings
mps UnboundEntityDef
entDef = do
    ([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 a. a -> Q a
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 a. a -> Q a
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 a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Name]
allInstances)
                      else do
                        [Dec]
bi <- Q [Dec]
backendKeyI
                        ([Dec], [Name]) -> Q ([Dec], [Name])
forall a. a -> Q a
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
typeclass ->
            if (Bool -> Bool
not Bool
useNewtype Bool -> Bool -> Bool
|| Name
typeclass Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
alwaysStockStrategyTypeclasses)
                then Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) [(Name -> Type
ConT Name
typeclass)]
                else Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
NewtypeStrategy) [(Name -> Type
ConT Name
typeclass)]
            ) [Name]
i

#if MIN_VERSION_template_haskell(2,15,0)
    let kd :: 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 a. a -> Q a
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) (NonEmpty VarBangType -> [VarBangType]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty VarBangType -> [VarBangType])
-> NonEmpty VarBangType -> [VarBangType]
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> UnboundEntityDef -> NonEmpty VarBangType
keyFields MkPersistSettings
mps UnboundEntityDef
entDef)
    k :: Name
k = ''Key
    recordType :: Type
recordType =
        MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS UnboundEntityDef
entDef) Type
backendT
    pfInstD :: Q [Dec]
pfInstD = -- FIXME: generate a PersistMap instead of PersistList
      [d|instance PersistField (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType)) where
            toPersistValue = PersistList . keyToValues
            fromPersistValue (PersistList l) = keyFromValues l
            fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got
         instance PersistFieldSql (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType)) where
            sqlType _ = SqlString
         instance ToJSON (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
         instance FromJSON (Key $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
recordType))
      |]

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

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

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

        [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 a. a -> Q a
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 = NonEmpty VarBangType -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (MkPersistSettings -> UnboundEntityDef -> NonEmpty VarBangType
keyFields MkPersistSettings
mps UnboundEntityDef
entDef) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2

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

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

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

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

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

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

-- needs:
--
-- * entityPrimary
-- * keyConExp entDef
mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
mkKeyFromValues MkPersistSettings
_mps UnboundEntityDef
entDef =
    Name -> [Clause] -> Dec
FunD 'keyFromValues ([Clause] -> Dec) -> Q [Clause] -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        case UnboundEntityDef -> PrimarySpec
unboundPrimarySpec UnboundEntityDef
entDef of
            NaturalKey UnboundCompositeDef
ucd ->
                UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
fromValues UnboundEntityDef
entDef Text
"keyFromValues" Exp
keyConE (NonEmpty FieldNameHS -> [FieldNameHS]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols UnboundCompositeDef
ucd)
            PrimarySpec
_ -> do
                Exp
e <- [|fmap $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
keyConE) . fromPersistValue . headNote|]
                [Clause] -> Q [Clause]
forall a. a -> Q a
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
forall (m :: * -> *). Quote m => String -> m 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 $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x))|]
    Clause
suc <- Q Clause
patternSuccess
    [Clause] -> Q [Clause]
forall a. a -> Q a
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 a. a -> Q a
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
forall (m :: * -> *). Quote m => String -> m 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
i -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"x" String -> 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 a. [a] -> 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> Q a
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 a b. (a -> b) -> [a] -> [b]
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 b a. (b -> a -> b) -> b -> [a] -> b
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 :: forall a.
Map EntityNameHS a
-> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
mkEntity Map EntityNameHS a
embedEntityMap EntityMap
entityMap MkPersistSettings
mps UnboundEntityDef
preDef = do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EntityDef -> Bool
isEntitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
preDef)) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
        String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"persistent has deprecated sum type entities as of 2.14.0.0."
            , String
"We will delete support for these entities in 2.15.0.0."
            , String
"If you need these, please add a comment on this GitHub issue:"
            , String
""
            , String
"    https://github.com/yesodweb/persistent/issues/987"
            ]

    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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 -> Type -> Q [Clause]
mkLensClauses MkPersistSettings
mps UnboundEntityDef
entDef Type
genDataType

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

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

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

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


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

    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [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'
        , Dec
mkTabulateA
        , Name -> [Clause] -> Dec
FunD 'entityDef [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
entityDefExp]
        , Dec
tpf
        , Name -> [Clause] -> Dec
FunD 'fromPersistValues [Clause]
fpv
        , Dec
toFieldNames
        , Dec
utv
        , Dec
puk
#if MIN_VERSION_template_haskell(2,15,0)
        , [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD
            []
            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 :: EntityFieldsTH -> [EntityFieldTH]
entityFieldsTHPrimary :: EntityFieldsTH -> EntityFieldTH
entityFieldsTHPrimary :: EntityFieldTH
entityFieldsTHFields :: [EntityFieldTH]
..} =
    EntityFieldTH -> EntityFieldTH
stripIdFieldDef EntityFieldTH
entityFieldsTHPrimary EntityFieldTH -> [EntityFieldTH] -> [EntityFieldTH]
forall a. a -> [a] -> [a]
: [EntityFieldTH]
entityFieldsTHFields

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

-- | @persistent@ used to assume that an Id was always a single field.
--
-- This method preserves as much backwards compatibility as possible.
stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef
stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef
stripIdFieldImpl EntityIdDef
eid =
    case EntityIdDef
eid of
        EntityIdField FieldDef
fd -> FieldDef
fd
        EntityIdNaturalKey CompositeDef
cd ->
            case CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
cd of
                (FieldDef
x :| [FieldDef]
xs) ->
                    case [FieldDef]
xs of
                        [] ->
                            FieldDef
x
                        [FieldDef]
_ ->
                            FieldDef
dummyFieldDef
  where
    dummyFieldDef :: FieldDef
dummyFieldDef =
        FieldDef
            { fieldHaskell :: FieldNameHS
fieldHaskell =
                Text -> FieldNameHS
FieldNameHS Text
"Id"
            , fieldDB :: FieldNameDB
fieldDB =
                Text -> FieldNameDB
FieldNameDB Text
"__composite_key_no_id__"
            , fieldType :: FieldType
fieldType =
                Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
"__Composite_Key__"
            , fieldSqlType :: SqlType
fieldSqlType =
                Text -> SqlType
SqlOther Text
"Composite Key"
            , fieldAttrs :: [FieldAttr]
fieldAttrs =
                []
            , fieldStrict :: Bool
fieldStrict =
                Bool
False
            , fieldReference :: ReferenceDef
fieldReference =
                ReferenceDef
NoReference
            , fieldCascade :: FieldCascade
fieldCascade =
                FieldCascade
noCascade
            , fieldComments :: Maybe Text
fieldComments =
                Maybe Text
forall a. Maybe a
Nothing
            , fieldGenerated :: Maybe Text
fieldGenerated =
                Maybe Text
forall a. Maybe a
Nothing
            , fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn =
                Bool
False
            }

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

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

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

    typeErrorNoneCtx :: Q [Type]
typeErrorNoneCtx = do
        Type
tyErr <- [t|TypeError (NoUniqueKeysError $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
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 $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
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 a. a -> Q a
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 a. a -> Q a
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 a. a -> Q a
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 a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkLenses MkPersistSettings
_ EntityMap
_ UnboundEntityDef
ent | EntityDef -> Bool
entitySum (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ent) = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkLenses MkPersistSettings
mps EntityMap
entityMap UnboundEntityDef
ent = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [(UnboundFieldDef, Name)]
-> ((UnboundFieldDef, Name) -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ent [UnboundFieldDef] -> [Name] -> [(UnboundFieldDef, Name)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
fieldNames) (((UnboundFieldDef, Name) -> Q [Dec]) -> Q [[Dec]])
-> ((UnboundFieldDef, Name) -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \(UnboundFieldDef
field, Name
fieldName) -> do
    let lensName :: Name
lensName = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
mkEntityLensName MkPersistSettings
mps UnboundEntityDef
ent UnboundFieldDef
field
    Name
needleN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"needle"
    Name
setterN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"setter"
    Name
fN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
    Name
aN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
    Name
yN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    let needle :: Exp
needle = Name -> Exp
VarE Name
needleN
        setter :: Exp
setter = Name -> Exp
VarE Name
setterN
        f :: Exp
f = Name -> Exp
VarE Name
fN
        a :: Exp
a = Name -> Exp
VarE Name
aN
        y :: Exp
y = Name -> Exp
VarE Name
yN
        fT :: Name
fT = String -> Name
mkName String
"f"
        -- FIXME if we want to get really fancy, then: if this field is the
        -- *only* Id field present, then set backend1 and backend2 to different
        -- values
        backend1 :: Name
backend1 = Name
backendName
        backend2 :: Name
backend2 = Name
backendName
        aT :: Type
aT =
            MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
field (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 Specificity]
vars = Name -> TyVarBndr Specificity
mkForallTV Name
fT
             TyVarBndr Specificity
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. a -> [a] -> [a]
: (if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps then [Name -> TyVarBndr Specificity
mkForallTV Name
backend1{-, PlainTV backend2-}] else [])
    Exp
fieldUpdClause <- Name -> [Name] -> Exp -> Name -> Exp -> Q Exp
fieldUpd (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ent) [Name]
fieldNames Exp
a Name
fieldName Exp
y
    [Dec] -> Q [Dec]
forall a. a -> Q a
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 Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
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 a. a -> [a]
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 -> Name -> Exp
fieldSel (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
ent) 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 a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
                [Name -> Pat
VarP Name
yN]
                Exp
fieldUpdClause
            ]
        ]
    where
        fieldNames :: [Name]
fieldNames = MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
fieldDefToRecordName MkPersistSettings
mps UnboundEntityDef
ent (UnboundFieldDef -> Name) -> [UnboundFieldDef] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs UnboundEntityDef
ent

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

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

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

mkPlainTV
    :: Name
    -> TyVarBndr
mkPlainTV = PlainTV

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

mkForeignKeysComposite
    :: MkPersistSettings
    -> UnboundEntityDef
    -> UnboundForeignDef
    -> Q [Dec]
mkForeignKeysComposite :: MkPersistSettings
-> UnboundEntityDef -> UnboundForeignDef -> Q [Dec]
mkForeignKeysComposite MkPersistSettings
mps UnboundEntityDef
entDef UnboundForeignDef
foreignDef
    | ForeignDef -> Bool
foreignToPrimary (UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef) = do
        let
            fieldName :: FieldNameHS -> Name
fieldName =
                MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
fieldNameToRecordName MkPersistSettings
mps UnboundEntityDef
entDef
            fname :: Name
fname =
                FieldNameHS -> Name
fieldName (FieldNameHS -> Name) -> FieldNameHS -> Name
forall a b. (a -> b) -> a -> b
$ ConstraintNameHS -> FieldNameHS
constraintToField (ConstraintNameHS -> FieldNameHS)
-> ConstraintNameHS -> FieldNameHS
forall a b. (a -> b) -> a -> b
$ ForeignDef -> ConstraintNameHS
foreignConstraintNameHaskell (ForeignDef -> ConstraintNameHS) -> ForeignDef -> ConstraintNameHS
forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef
            reftableString :: String
reftableString =
                Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ ForeignDef -> EntityNameHS
foreignRefTableHaskell (ForeignDef -> EntityNameHS) -> ForeignDef -> EntityNameHS
forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> ForeignDef
unboundForeignDef UnboundForeignDef
foreignDef
            reftableKeyName :: Name
reftableKeyName =
                String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
reftableString String -> 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
recordVarName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"record_mkForeignKeysComposite"

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

            fldsE :: 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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldNameHS -> Exp
mkFldE NonEmpty FieldNameHS
xs
                FieldListHasReferences NonEmpty ForeignFieldReference
xs ->
                    (ForeignFieldReference -> Exp)
-> NonEmpty ForeignFieldReference -> NonEmpty Exp
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldReference -> Exp
mkFldR NonEmpty ForeignFieldReference
xs

            nullErr :: a -> 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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNameHS
n -> UnboundFieldDef -> Maybe UnboundFieldDef -> UnboundFieldDef
forall a. a -> Maybe a -> a
fromMaybe (FieldNameHS -> UnboundFieldDef
forall {a} {a}. Show a => a -> a
nullErr FieldNameHS
n) (Maybe UnboundFieldDef -> UnboundFieldDef)
-> Maybe UnboundFieldDef -> UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
getFieldDef FieldNameHS
n FieldStore
fieldStore)
                   (NonEmpty FieldNameHS -> NonEmpty UnboundFieldDef)
-> NonEmpty FieldNameHS -> NonEmpty UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ UnboundForeignFieldList -> NonEmpty FieldNameHS
foreignFieldNames
                   (UnboundForeignFieldList -> NonEmpty FieldNameHS)
-> UnboundForeignFieldList -> NonEmpty FieldNameHS
forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields UnboundForeignDef
foreignDef
            mkKeyE :: Exp
mkKeyE =
                (Exp -> Exp -> Exp) -> Exp -> NonEmpty Exp -> Exp
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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
recordVarName] 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| $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tablename) -> $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
keyTargetTable) |]
        [Dec] -> Q [Dec]
forall a. a -> Q a
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 a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    constraintToField :: ConstraintNameHS -> FieldNameHS
constraintToField = Text -> FieldNameHS
FieldNameHS (Text -> FieldNameHS)
-> (ConstraintNameHS -> Text) -> ConstraintNameHS -> FieldNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintNameHS -> Text
unConstraintNameHS


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

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

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

entityFromPersistValueHelper
    :: (PersistEntity record)
    => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code
    -> PersistValue
    -> Either Text record
entityFromPersistValueHelper :: forall record.
PersistEntity record =>
[String] -> PersistValue -> Either Text record
entityFromPersistValueHelper [String]
columnNames PersistValue
pv = do
    ([(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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PersistValue
lookupPersistValueByColumnName [String]
columnNames

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

    [Dec] -> Q [Dec]
forall a. a -> Q a
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> String
unpack (Text -> String)
-> (UnboundFieldDef -> Text) -> UnboundFieldDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> (UnboundFieldDef -> FieldNameHS) -> UnboundFieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS) [UnboundFieldDef]
entFields

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

-- | Creates a declaration for the @['EntityDef']@ from the @persistent@
-- schema. This is necessary because the Persistent QuasiQuoter is unable
-- to know the correct type of ID fields, and assumes that they are all
-- Int64.
--
-- Provide this in the list you give to 'share', much like @'mkMigrate'@.
--
-- @
-- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...]
-- @
--
-- @since 2.7.1
mkEntityDefList
    :: String
    -- ^ The name that will be given to the 'EntityDef' list.
    -> [UnboundEntityDef]
    -> Q [Dec]
mkEntityDefList :: String -> [UnboundEntityDef] -> Q [Dec]
mkEntityDefList String
entityList [UnboundEntityDef]
entityDefs = do
    let entityListName :: Name
entityListName = String -> Name
mkName String
entityList
    Exp
edefs <- ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE
        (Q [Exp] -> Q Exp)
-> ((UnboundEntityDef -> Q Exp) -> Q [Exp])
-> (UnboundEntityDef -> Q Exp)
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnboundEntityDef] -> (UnboundEntityDef -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnboundEntityDef]
entityDefs
        ((UnboundEntityDef -> Q Exp) -> Q Exp)
-> (UnboundEntityDef -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \UnboundEntityDef
entDef ->
            let entityType :: Q Type
entityType = UnboundEntityDef -> Q Type
entityDefConT UnboundEntityDef
entDef
             in [|entityDef (Proxy :: Proxy $(Q Type
entityType))|]
    Type
typ <- [t|[EntityDef]|]
    [Dec] -> Q [Dec]
forall a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] ([Exp] -> Exp
ListE [])]
mkUniqueKeys UnboundEntityDef
def = do
    Clause
c <- Q Clause
clause
    Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [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
forall (m :: * -> *). Quote m => String -> m 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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldNameHS
x, Name
x')
        let pcs :: [Exp]
pcs = (UniqueDef -> Exp) -> [UniqueDef] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(FieldNameHS, Name)] -> UniqueDef -> Exp
go [(FieldNameHS, Name)]
xs) ([UniqueDef] -> [Exp]) -> [UniqueDef] -> [Exp]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques (EntityDef -> [UniqueDef]) -> EntityDef -> [UniqueDef]
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
def
        let pat :: Pat
pat = Name -> [Pat] -> Pat
conp
                (UnboundEntityDef -> Name
mkEntityDefName UnboundEntityDef
def)
                (((FieldNameHS, Name) -> Pat) -> [(FieldNameHS, Name)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Pat
VarP (Name -> Pat)
-> ((FieldNameHS, Name) -> Name) -> (FieldNameHS, Name) -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, Name) -> Name
forall a b. (a, b) -> b
snd) [(FieldNameHS, Name)]
xs)
        Clause -> Q Clause
forall a. a -> Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ (ForeignFieldDef -> FieldNameHS)
-> NonEmpty ForeignFieldDef -> NonEmpty FieldNameHS
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignFieldDef -> FieldNameHS
forall a b. (a, b) -> a
fst NonEmpty ForeignFieldDef
cols)

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

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

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

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

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

-- | Automatically creates a valid 'PersistField' instance for any datatype
-- that has valid 'Show' and 'Read' instances. Can be very convenient for
-- 'Enum' types.
derivePersistField :: String -> Q [Dec]
derivePersistField :: String -> Q [Dec]
derivePersistField String
s = do
    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 a. a -> Q a
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 a. a -> Q a
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 $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
entityDefListName)) |]
    [Dec]
edList <- String -> [UnboundEntityDef] -> Q [Dec]
mkEntityDefList String
entityDefListName [UnboundEntityDef]
eds
    [Dec] -> Q [Dec]
forall a. a -> Q a
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 Specificity] -> [Type] -> Con -> Con
ForallC
                []
                [Type -> Type -> Type
mkEqualP (Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"typ") Type
fieldT]
                (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC Name
name []
        fieldT :: Type
fieldT =
            MkPersistSettings
-> EntityMap
-> UnboundFieldDef
-> Maybe Name
-> Maybe IsNullable
-> Type
maybeIdType MkPersistSettings
mps EntityMap
entityMap UnboundFieldDef
fieldDef Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing
    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 a. a -> Q a
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 a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntityFieldTH
        { entityFieldTHCon :: Con
entityFieldTHCon =
            [TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC
                []
                [Type -> Type -> Type
mkEqualP (Name -> Type
VarT (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 :: forall entity.
PersistEntity entity =>
Proxy entity -> FieldNameHS -> FieldDef
lookupEntityField Proxy entity
prxy FieldNameHS
fieldNameHS =
    FieldDef -> Maybe FieldDef -> FieldDef
forall a. a -> Maybe a -> a
fromMaybe FieldDef
forall {a}. a
boom (Maybe FieldDef -> FieldDef) -> Maybe FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Bool) -> [FieldDef] -> Maybe FieldDef
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((FieldNameHS
fieldNameHS FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
==) (FieldNameHS -> Bool)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell) ([FieldDef] -> Maybe FieldDef) -> [FieldDef] -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields (EntityDef -> [FieldDef]) -> EntityDef -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ Proxy entity -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
forall (proxy :: * -> *). proxy entity -> EntityDef
entityDef Proxy entity
prxy
  where
    boom :: a
boom =
        String -> a
forall a. HasCallStack => String -> a
error String
"Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name"

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

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

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

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

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

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

    let objectE :: Exp
objectE = Name -> Exp
VarE 'object
        withObjectE :: Exp
withObjectE = Name -> Exp
VarE 'withObject
        dotEqualE :: Exp
dotEqualE = Name -> Exp
VarE '(.=)
        dotColonE :: Exp
dotColonE = Name -> Exp
VarE '(.:)
        dotColonQE :: Exp
dotColonQE = Name -> Exp
VarE '(.:?)
#if MIN_VERSION_aeson(2,0,0)
        toKeyE :: Exp
toKeyE = Name -> Exp
VarE 'Key.fromString
#else
        toKeyE = VarE 'pack
#endif
    Name
obj <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
                [Name -> [Pat] -> Pat
conp Name
conName ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
xs]
                (Exp
objectE Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
pairs)
              where
                pairs :: [Exp]
pairs = (UnboundFieldDef -> Name -> Exp)
-> [UnboundFieldDef] -> [Name] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith UnboundFieldDef -> Name -> Exp
toPair [UnboundFieldDef]
fields [Name]
xs
                toPair :: UnboundFieldDef -> Name -> Exp
toPair UnboundFieldDef
f Name
x = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp
toKeyE Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text) -> FieldNameHS -> Text
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
f)))
                    Exp
dotEqualE
                    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x)
        fromJSONI :: 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 b a. (b -> a -> b) -> b -> [a] -> b
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnboundFieldDef -> Exp
toPull [UnboundFieldDef]
fields
                toPull :: UnboundFieldDef -> Exp
toPull UnboundFieldDef
f = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
obj)
                    (if UnboundFieldDef -> Bool
maybeNullable UnboundFieldDef
f then Exp
dotColonQE else Exp
dotColonE)
                    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
toKeyE (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text) -> FieldNameHS -> Text
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
f)

    case MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON MkPersistSettings
mps of
        Maybe EntityJSON
Nothing ->
            [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
toJSONI, Dec
fromJSONI]
        Just EntityJSON
entityJSON -> do
            [Dec]
entityJSONIs <- if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
              then [d|
                instance PersistStore $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT) => ToJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
                    toJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityToJSON EntityJSON
entityJSON))
                instance PersistStore $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
backendT) => FromJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
                    parseJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityFromJSON EntityJSON
entityJSON))
                |]
              else [d|
                instance ToJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
                    toJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityToJSON EntityJSON
entityJSON))
                instance FromJSON (Entity $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) where
                    parseJSON = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (EntityJSON -> Name
entityFromJSON EntityJSON
entityJSON))
                |]
            [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ 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 b a. (b -> a -> b) -> b -> [a] -> b
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> [Extension]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Extension
DerivingStrategies
        , Extension
GeneralizedNewtypeDeriving
        , Extension
StandaloneDeriving
        , Extension
UndecidableInstances
        , Extension
MultiParamTypeClasses
        ]

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

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

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

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

    [Dec]
mkey <- 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
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Key Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
recordNameT
                Q Type -> Q Type -> Q Exp -> Q [Dec]
mkInstance [t|"id"|] Q Type
fieldTypeT Q Exp
entityFieldConstr

    [Dec] -> Q [Dec]
forall a. a -> Q a
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
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nameG Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
backendName
        | Bool
otherwise =
            UnboundEntityDef -> Q Type
entityDefConT UnboundEntityDef
ed
    mkInstance :: Q Type -> Q Type -> Q Exp -> Q [Dec]
mkInstance Q Type
fieldNameT Q Type
fieldTypeT Q Exp
entityFieldConstr =
        [d|
            instance SymbolToField $(Q Type
fieldNameT) $(Q Type
recordNameT) $(Q Type
fieldTypeT) where
                symbolToField = $(Q Exp
entityFieldConstr)
            |]

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

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

  where
    extensionToPragma :: a -> String
extensionToPragma a
ext = String
"{-# LANGUAGE " String -> 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
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name)
-> (UnboundFieldDef -> String) -> UnboundFieldDef -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (UnboundFieldDef -> Text) -> UnboundFieldDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHSForJSON (FieldNameHS -> Text)
-> (UnboundFieldDef -> FieldNameHS) -> UnboundFieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> FieldNameHS
unboundFieldNameHS

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

For example,

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

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

@
migrateAll = migrateModels $(discoverEntities)
@

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

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

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

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

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

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

@since 2.13.0.0
-}
discoverEntities :: Q Exp
discoverEntities :: Q Exp
discoverEntities = do
    [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 a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
        [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 $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ)) |]

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