{-# LANGUAGE CPP, BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveLift #-}

-- {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}

-- | This module provides the tools for defining your database schema and using
-- it to generate Haskell data types and migrations.
module Database.Persist.TH
    ( -- * Parse entity defs
      persistWith
    , persistUpperCase
    , persistLowerCase
    , persistFileWith
    , persistManyFileWith
      -- * Turn @EntityDef@s into types
    , mkPersist
    , MkPersistSettings
    , mpsBackend
    , mpsGeneric
    , mpsPrefixFields
    , mpsFieldLabelModifier
    , mpsConstraintLabelModifier
    , mpsEntityJSON
    , mpsGenerateLenses
    , mpsDeriveInstances
    , EntityJSON(..)
    , mkPersistSettings
    , sqlSettings
      -- * Various other TH functions
    , mkMigrate
    , mkSave
    , mkDeleteCascade
    , mkEntityDefList
    , share
    , derivePersistField
    , derivePersistFieldJSON
    , persistFieldFromEntity
      -- * Internal
    , lensPTH
    , parseReferences
    , embedEntityDefs
    , fieldError
    , AtLeastOneUniqueKey(..)
    , OnlyOneUniqueKey(..)
    , pkNewtype
    ) where

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

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

import Data.Either
import Control.Monad
import Data.Aeson
    ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object
    , Value (Object), (.:), (.:?)
    , eitherDecodeStrict'
    )
import qualified Data.ByteString as BS
import Data.Typeable (Typeable)
import Data.Ix (Ix)
import Data.Data (Data)
import Data.Char (toLower, toUpper)
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.List (foldl')
import qualified Data.List as List
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe)
import Data.Monoid ((<>), mappend, mconcat)
import Data.Proxy (Proxy (Proxy))
import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
import GHC.Generics (Generic)
import GHC.TypeLits
import Instances.TH.Lift ()
    -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text`
    -- instance on pre-1.2.4 versions of `text`
import Language.Haskell.TH.Lib (appT, varT, conT, varE, varP, conE, litT, strTyLit)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.PathPieces (PathPiece(..))
import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..))
import qualified Data.Set as Set

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

-- | 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

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

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

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

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

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

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

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

embedEntityDefsMap :: [EntityDef] -> (M.Map EntityNameHS EmbedEntityDef, [EntityDef])
embedEntityDefsMap :: [EntityDef] -> (Map EntityNameHS EmbedEntityDef, [EntityDef])
embedEntityDefsMap [EntityDef]
rawEnts = (Map EntityNameHS EmbedEntityDef
embedEntityMap, [EntityDef]
noCycleEnts)
  where
    noCycleEnts :: [EntityDef]
noCycleEnts = (EntityDef -> EntityDef) -> [EntityDef] -> [EntityDef]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> EntityDef
breakCycleEnt [EntityDef]
entsWithEmbeds
    -- every EntityDef could reference each-other (as an EmbedRef)
    -- let Haskell tie the knot
    embedEntityMap :: Map EntityNameHS EmbedEntityDef
embedEntityMap = [EntityDef] -> Map EntityNameHS EmbedEntityDef
constructEmbedEntityMap [EntityDef]
entsWithEmbeds
    entsWithEmbeds :: [EntityDef]
entsWithEmbeds = (EntityDef -> EntityDef) -> [EntityDef] -> [EntityDef]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> EntityDef
setEmbedEntity [EntityDef]
rawEnts
    setEmbedEntity :: EntityDef -> EntityDef
setEmbedEntity EntityDef
ent = EntityDef
ent
        { entityFields :: [FieldDef]
entityFields = (FieldDef -> FieldDef) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (EntityNameHS
-> Map EntityNameHS EmbedEntityDef -> FieldDef -> FieldDef
setEmbedField (EntityDef -> EntityNameHS
entityHaskell EntityDef
ent) Map EntityNameHS EmbedEntityDef
embedEntityMap) ([FieldDef] -> [FieldDef]) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
ent
        }

    -- self references are already broken
    -- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS
    -- so start with entityHaskell ent and accumulate embeddedHaskell em
    breakCycleEnt :: EntityDef -> EntityDef
breakCycleEnt EntityDef
entDef =
        let entName :: EntityNameHS
entName = EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef
         in EntityDef
entDef { entityFields :: [FieldDef]
entityFields = (FieldDef -> FieldDef) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (EntityNameHS -> FieldDef -> FieldDef
breakCycleField EntityNameHS
entName) ([FieldDef] -> [FieldDef]) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
entDef }

    breakCycleField :: EntityNameHS -> FieldDef -> FieldDef
breakCycleField EntityNameHS
entName FieldDef
f = case FieldDef
f of
        FieldDef { fieldReference :: FieldDef -> ReferenceDef
fieldReference = EmbedRef EmbedEntityDef
em } ->
            FieldDef
f { fieldReference :: ReferenceDef
fieldReference = EmbedEntityDef -> ReferenceDef
EmbedRef (EmbedEntityDef -> ReferenceDef) -> EmbedEntityDef -> ReferenceDef
forall a b. (a -> b) -> a -> b
$ [EntityNameHS] -> EmbedEntityDef -> EmbedEntityDef
breakCycleEmbed [EntityNameHS
entName] EmbedEntityDef
em }
        FieldDef
_ ->
            FieldDef
f

    breakCycleEmbed :: [EntityNameHS] -> EmbedEntityDef -> EmbedEntityDef
breakCycleEmbed [EntityNameHS]
ancestors EmbedEntityDef
em =
        EmbedEntityDef
em { embeddedFields :: [EmbedFieldDef]
embeddedFields = [EntityNameHS] -> EmbedFieldDef -> EmbedFieldDef
breakCycleEmField (EntityNameHS
emName EntityNameHS -> [EntityNameHS] -> [EntityNameHS]
forall a. a -> [a] -> [a]
: [EntityNameHS]
ancestors) (EmbedFieldDef -> EmbedFieldDef)
-> [EmbedFieldDef] -> [EmbedFieldDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EmbedEntityDef -> [EmbedFieldDef]
embeddedFields EmbedEntityDef
em
           }
        where
            emName :: EntityNameHS
emName = EmbedEntityDef -> EntityNameHS
embeddedHaskell EmbedEntityDef
em

    breakCycleEmField :: [EntityNameHS] -> EmbedFieldDef -> EmbedFieldDef
breakCycleEmField [EntityNameHS]
ancestors EmbedFieldDef
emf = case EmbedEntityDef -> EntityNameHS
embeddedHaskell (EmbedEntityDef -> EntityNameHS)
-> Maybe EmbedEntityDef -> Maybe EntityNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EmbedEntityDef
membed of
        Maybe EntityNameHS
Nothing -> EmbedFieldDef
emf
        Just EntityNameHS
embName -> if EntityNameHS
embName EntityNameHS -> [EntityNameHS] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EntityNameHS]
ancestors
            then EmbedFieldDef
emf { emFieldEmbed :: Maybe EmbedEntityDef
emFieldEmbed = Maybe EmbedEntityDef
forall a. Maybe a
Nothing, emFieldCycle :: Maybe EntityNameHS
emFieldCycle = EntityNameHS -> Maybe EntityNameHS
forall a. a -> Maybe a
Just EntityNameHS
embName }
            else EmbedFieldDef
emf { emFieldEmbed :: Maybe EmbedEntityDef
emFieldEmbed = [EntityNameHS] -> EmbedEntityDef -> EmbedEntityDef
breakCycleEmbed [EntityNameHS]
ancestors (EmbedEntityDef -> EmbedEntityDef)
-> Maybe EmbedEntityDef -> Maybe EmbedEntityDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EmbedEntityDef
membed }
        where
            membed :: Maybe EmbedEntityDef
membed = EmbedFieldDef -> Maybe EmbedEntityDef
emFieldEmbed EmbedFieldDef
emf

-- calls parse to Quasi.parse individual entities in isolation
-- afterwards, sets references to other entities
-- | @since 2.5.3
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences PersistSettings
ps Text
s = [EntityDefSqlTypeExp] -> Q Exp
forall t. Lift t => t -> Q Exp
lift ([EntityDefSqlTypeExp] -> Q Exp) -> [EntityDefSqlTypeExp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
    (EntityDef -> EntityDefSqlTypeExp)
-> [EntityDef] -> [EntityDefSqlTypeExp]
forall a b. (a -> b) -> [a] -> [b]
map (Map EntityNameHS EmbedEntityDef
-> EntityMap -> EntityDef -> EntityDefSqlTypeExp
mkEntityDefSqlTypeExp Map EntityNameHS EmbedEntityDef
embedEntityMap EntityMap
entityMap) [EntityDef]
noCycleEnts
  where
    (Map EntityNameHS EmbedEntityDef
embedEntityMap, [EntityDef]
noCycleEnts) = [EntityDef] -> (Map EntityNameHS EmbedEntityDef, [EntityDef])
embedEntityDefsMap ([EntityDef] -> (Map EntityNameHS EmbedEntityDef, [EntityDef]))
-> [EntityDef] -> (Map EntityNameHS EmbedEntityDef, [EntityDef])
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [EntityDef]
parse PersistSettings
ps Text
s
    entityMap :: EntityMap
entityMap = [EntityDef] -> EntityMap
constructEntityMap [EntityDef]
noCycleEnts

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

foreignReference :: FieldDef -> Maybe EntityNameHS
foreignReference :: FieldDef -> Maybe EntityNameHS
foreignReference FieldDef
field = case FieldDef -> ReferenceDef
fieldReference FieldDef
field of
    ForeignRef EntityNameHS
ref FieldType
_ -> EntityNameHS -> Maybe EntityNameHS
forall a. a -> Maybe a
Just EntityNameHS
ref
    ReferenceDef
_              -> Maybe EntityNameHS
forall a. Maybe a
Nothing


-- fieldSqlType at parse time can be an Exp
-- This helps delay setting fieldSqlType until lift time
data EntityDefSqlTypeExp
    = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp]
    deriving Int -> EntityDefSqlTypeExp -> ShowS
[EntityDefSqlTypeExp] -> ShowS
EntityDefSqlTypeExp -> String
(Int -> EntityDefSqlTypeExp -> ShowS)
-> (EntityDefSqlTypeExp -> String)
-> ([EntityDefSqlTypeExp] -> ShowS)
-> Show EntityDefSqlTypeExp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EntityDefSqlTypeExp] -> ShowS
$cshowList :: [EntityDefSqlTypeExp] -> ShowS
show :: EntityDefSqlTypeExp -> String
$cshow :: EntityDefSqlTypeExp -> String
showsPrec :: Int -> EntityDefSqlTypeExp -> ShowS
$cshowsPrec :: Int -> EntityDefSqlTypeExp -> ShowS
Show

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

instance Lift SqlTypeExp where
    lift :: SqlTypeExp -> Q Exp
lift (SqlType' SqlType
t)       = SqlType -> Q Exp
forall t. Lift t => t -> Q Exp
lift SqlType
t
    lift (SqlTypeExp FieldType
ftype) = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
st
        where
            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
            st :: Exp
st = Name -> Exp
VarE 'sqlType Exp -> Exp -> Exp
`AppE` Exp
typedNothing
#if MIN_VERSION_template_haskell(2,16,0)
    liftTyped :: SqlTypeExp -> Q (TExp SqlTypeExp)
liftTyped = Q Exp -> Q (TExp SqlTypeExp)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp SqlTypeExp))
-> (SqlTypeExp -> Q Exp) -> SqlTypeExp -> Q (TExp SqlTypeExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlTypeExp -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp]

instance Lift FieldsSqlTypeExp where
    lift :: FieldsSqlTypeExp -> Q Exp
lift (FieldsSqlTypeExp [FieldDef]
fields [SqlTypeExp]
sqlTypeExps) =
        [FieldSqlTypeExp] -> Q Exp
forall t. Lift t => t -> Q Exp
lift ([FieldSqlTypeExp] -> Q Exp) -> [FieldSqlTypeExp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (FieldDef -> SqlTypeExp -> FieldSqlTypeExp)
-> [FieldDef] -> [SqlTypeExp] -> [FieldSqlTypeExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldDef -> SqlTypeExp -> FieldSqlTypeExp
FieldSqlTypeExp [FieldDef]
fields [SqlTypeExp]
sqlTypeExps
#if MIN_VERSION_template_haskell(2,16,0)
    liftTyped :: FieldsSqlTypeExp -> Q (TExp FieldsSqlTypeExp)
liftTyped = Q Exp -> Q (TExp FieldsSqlTypeExp)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp FieldsSqlTypeExp))
-> (FieldsSqlTypeExp -> Q Exp)
-> FieldsSqlTypeExp
-> Q (TExp FieldsSqlTypeExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldsSqlTypeExp -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp

instance Lift FieldSqlTypeExp where
    lift :: FieldSqlTypeExp -> Q Exp
lift (FieldSqlTypeExp FieldDef{Bool
[FieldAttr]
Maybe Text
SqlType
FieldCascade
ReferenceDef
FieldNameHS
FieldNameDB
FieldType
fieldGenerated :: FieldDef -> Maybe Text
fieldComments :: FieldDef -> Maybe Text
fieldCascade :: FieldDef -> FieldCascade
fieldStrict :: FieldDef -> Bool
fieldAttrs :: FieldDef -> [FieldAttr]
fieldSqlType :: FieldDef -> SqlType
fieldType :: FieldDef -> FieldType
fieldDB :: FieldDef -> FieldNameDB
fieldHaskell :: FieldDef -> FieldNameHS
fieldGenerated :: Maybe Text
fieldComments :: Maybe Text
fieldCascade :: FieldCascade
fieldReference :: ReferenceDef
fieldStrict :: Bool
fieldAttrs :: [FieldAttr]
fieldSqlType :: SqlType
fieldType :: FieldType
fieldDB :: FieldNameDB
fieldHaskell :: FieldNameHS
fieldReference :: FieldDef -> ReferenceDef
..} SqlTypeExp
sqlTypeExp) =
        [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments fieldGenerated|]
      where
        FieldDef FieldNameHS
_x FieldNameDB
_ FieldType
_ SqlType
_ [FieldAttr]
_ Bool
_ ReferenceDef
_ FieldCascade
_ Maybe Text
_ Maybe Text
_ =
            String -> FieldDef
forall a. HasCallStack => String -> a
error String
"need to update this record wildcard match"
#if MIN_VERSION_template_haskell(2,16,0)
    liftTyped :: FieldSqlTypeExp -> Q (TExp FieldSqlTypeExp)
liftTyped = Q Exp -> Q (TExp FieldSqlTypeExp)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp FieldSqlTypeExp))
-> (FieldSqlTypeExp -> Q Exp)
-> FieldSqlTypeExp
-> Q (TExp FieldSqlTypeExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldSqlTypeExp -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

instance Lift EntityDefSqlTypeExp where
    lift :: EntityDefSqlTypeExp -> Q Exp
lift (EntityDefSqlTypeExp EntityDef
ent SqlTypeExp
sqlTypeExp [SqlTypeExp]
sqlTypeExps) =
        [|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps)
              , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)
              }
        |]
#if MIN_VERSION_template_haskell(2,16,0)
    liftTyped :: EntityDefSqlTypeExp -> Q (TExp EntityDefSqlTypeExp)
liftTyped = Q Exp -> Q (TExp EntityDefSqlTypeExp)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp EntityDefSqlTypeExp))
-> (EntityDefSqlTypeExp -> Q Exp)
-> EntityDefSqlTypeExp
-> Q (TExp EntityDefSqlTypeExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDefSqlTypeExp -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

type EmbedEntityMap = M.Map EntityNameHS EmbedEntityDef

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

type EntityMap = M.Map EntityNameHS EntityDef

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

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

-- | Recurses through the 'FieldType'. Returns a 'Right' with the
-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of
-- a name and that name is present in the 'EmbedEntityMap' provided as
-- a first argument.
--
-- If the 'FieldType' represents a @Key something@, this returns a @'Left
-- ('Just' 'FTKeyCon')@.
--
-- If the 'FieldType' has a module qualified value, then it returns @'Left'
-- 'Nothing'@.
mEmbedded
    :: EmbedEntityMap
    -> FieldType
    -> Either (Maybe FTTypeConDescr) EmbedEntityDef
mEmbedded :: Map EntityNameHS EmbedEntityDef
-> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef
mEmbedded Map EntityNameHS EmbedEntityDef
_ (FTTypeCon Just{} Text
_) =
    Maybe FTTypeConDescr
-> Either (Maybe FTTypeConDescr) EmbedEntityDef
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing
mEmbedded Map EntityNameHS EmbedEntityDef
ents (FTTypeCon Maybe Text
Nothing (Text -> EntityNameHS
EntityNameHS -> EntityNameHS
name)) =
    Either (Maybe FTTypeConDescr) EmbedEntityDef
-> (EmbedEntityDef -> Either (Maybe FTTypeConDescr) EmbedEntityDef)
-> Maybe EmbedEntityDef
-> Either (Maybe FTTypeConDescr) EmbedEntityDef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe FTTypeConDescr
-> Either (Maybe FTTypeConDescr) EmbedEntityDef
forall a b. a -> Either a b
Left Maybe FTTypeConDescr
forall a. Maybe a
Nothing) EmbedEntityDef -> Either (Maybe FTTypeConDescr) EmbedEntityDef
forall a b. b -> Either a b
Right (Maybe EmbedEntityDef
 -> Either (Maybe FTTypeConDescr) EmbedEntityDef)
-> Maybe EmbedEntityDef
-> Either (Maybe FTTypeConDescr) EmbedEntityDef
forall a b. (a -> b) -> a -> b
$ EntityNameHS
-> Map EntityNameHS EmbedEntityDef -> Maybe EmbedEntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
name Map EntityNameHS EmbedEntityDef
ents
mEmbedded Map EntityNameHS EmbedEntityDef
ents (FTList FieldType
x) =
    Map EntityNameHS EmbedEntityDef
-> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef
mEmbedded Map EntityNameHS EmbedEntityDef
ents FieldType
x
mEmbedded Map EntityNameHS EmbedEntityDef
ents (FTApp FieldType
x FieldType
y) =
    -- Key converts an Record to a RecordId
    -- special casing this is obviously a hack
    -- This problem may not be solvable with the current QuasiQuoted approach though
    if FieldType
x FieldType -> FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
"Key"
        then Maybe FTTypeConDescr
-> Either (Maybe FTTypeConDescr) EmbedEntityDef
forall a b. a -> Either a b
Left (Maybe FTTypeConDescr
 -> Either (Maybe FTTypeConDescr) EmbedEntityDef)
-> Maybe FTTypeConDescr
-> Either (Maybe FTTypeConDescr) EmbedEntityDef
forall a b. (a -> b) -> a -> b
$ FTTypeConDescr -> Maybe FTTypeConDescr
forall a. a -> Maybe a
Just FTTypeConDescr
FTKeyCon
        else Map EntityNameHS EmbedEntityDef
-> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef
mEmbedded Map EntityNameHS EmbedEntityDef
ents FieldType
y

setEmbedField :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef
setEmbedField :: EntityNameHS
-> Map EntityNameHS EmbedEntityDef -> FieldDef -> FieldDef
setEmbedField EntityNameHS
entName Map EntityNameHS EmbedEntityDef
allEntities FieldDef
field = FieldDef
field
    { fieldReference :: ReferenceDef
fieldReference =
        case FieldDef -> ReferenceDef
fieldReference FieldDef
field of
            ReferenceDef
NoReference ->
                case Map EntityNameHS EmbedEntityDef
-> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef
mEmbedded Map EntityNameHS EmbedEntityDef
allEntities (FieldDef -> FieldType
fieldType FieldDef
field) of
                    Left Maybe FTTypeConDescr
_ ->
                        case FieldType -> Maybe Text
stripId (FieldType -> Maybe Text) -> FieldType -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
field of
                            Maybe Text
Nothing ->
                                ReferenceDef
NoReference
                            Just Text
name ->
                                case EntityNameHS
-> Map EntityNameHS EmbedEntityDef -> Maybe EmbedEntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> EntityNameHS
EntityNameHS Text
name) Map EntityNameHS EmbedEntityDef
allEntities of
                                    Maybe EmbedEntityDef
Nothing ->
                                        ReferenceDef
NoReference
                                    Just EmbedEntityDef
_ ->
                                        EntityNameHS -> FieldType -> ReferenceDef
ForeignRef
                                            (Text -> EntityNameHS
EntityNameHS Text
name)
                                            -- This can get corrected in mkEntityDefSqlTypeExp
                                            (Maybe Text -> Text -> FieldType
FTTypeCon (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Data.Int") Text
"Int64")
                    Right EmbedEntityDef
em ->
                        if EmbedEntityDef -> EntityNameHS
embeddedHaskell EmbedEntityDef
em EntityNameHS -> EntityNameHS -> Bool
forall a. Eq a => a -> a -> Bool
/= EntityNameHS
entName
                             then EmbedEntityDef -> ReferenceDef
EmbedRef EmbedEntityDef
em
                        else if FieldDef -> Bool
maybeNullable 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"
            ReferenceDef
existing ->
                ReferenceDef
existing
  }

mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp
mkEntityDefSqlTypeExp :: Map EntityNameHS EmbedEntityDef
-> EntityMap -> EntityDef -> EntityDefSqlTypeExp
mkEntityDefSqlTypeExp Map EntityNameHS EmbedEntityDef
emEntities EntityMap
entityMap EntityDef
ent =
    EntityDef -> SqlTypeExp -> [SqlTypeExp] -> EntityDefSqlTypeExp
EntityDefSqlTypeExp EntityDef
ent (FieldDef -> SqlTypeExp
getSqlType (FieldDef -> SqlTypeExp) -> FieldDef -> SqlTypeExp
forall a b. (a -> b) -> a -> b
$ EntityDef -> FieldDef
entityId EntityDef
ent) ((FieldDef -> SqlTypeExp) -> [FieldDef] -> [SqlTypeExp]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> SqlTypeExp
getSqlType ([FieldDef] -> [SqlTypeExp]) -> [FieldDef] -> [SqlTypeExp]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
ent)
  where
    getSqlType :: FieldDef -> SqlTypeExp
getSqlType FieldDef
field =
        SqlTypeExp -> (Text -> SqlTypeExp) -> Maybe Text -> SqlTypeExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (FieldDef -> SqlTypeExp
defaultSqlTypeExp FieldDef
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 (\case {FieldAttrSqltype Text
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x; FieldAttr
_ -> Maybe Text
forall a. Maybe a
Nothing}) ([FieldAttr] -> [Text]) -> [FieldAttr] -> [Text]
forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
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 :: FieldDef -> SqlTypeExp
defaultSqlTypeExp FieldDef
field =
        case Map EntityNameHS EmbedEntityDef
-> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef
mEmbedded Map EntityNameHS EmbedEntityDef
emEntities FieldType
ftype of
            Right EmbedEntityDef
_ ->
                SqlType -> SqlTypeExp
SqlType' SqlType
SqlString
            Left (Just FTTypeConDescr
FTKeyCon) ->
                SqlType -> SqlTypeExp
SqlType' SqlType
SqlString
            Left Maybe FTTypeConDescr
Nothing ->
                case FieldDef -> ReferenceDef
fieldReference FieldDef
field of
                    ForeignRef EntityNameHS
refName FieldType
ft ->
                        case EntityNameHS -> EntityMap -> Maybe EntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
refName EntityMap
entityMap of
                            Maybe EntityDef
Nothing  -> FieldType -> SqlTypeExp
SqlTypeExp FieldType
ft
                            -- A ForeignRef is blindly set to an Int64 in setEmbedField
                            -- correct that now
                            Just EntityDef
ent' ->
                                case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
ent' of
                                    Maybe CompositeDef
Nothing -> FieldType -> SqlTypeExp
SqlTypeExp FieldType
ft
                                    Just CompositeDef
pdef ->
                                        case CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef of
                                            [] -> String -> SqlTypeExp
forall a. HasCallStack => String -> a
error String
"mkEntityDefSqlTypeExp: no composite fields"
                                            [FieldDef
x] -> FieldType -> SqlTypeExp
SqlTypeExp (FieldType -> SqlTypeExp) -> FieldType -> SqlTypeExp
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
x
                                            [FieldDef]
_ -> SqlType -> SqlTypeExp
SqlType' (SqlType -> SqlTypeExp) -> SqlType -> SqlTypeExp
forall a b. (a -> b) -> a -> b
$ Text -> SqlType
SqlOther Text
"Composite Reference"
                    CompositeRef CompositeDef
_ ->
                        SqlType -> SqlTypeExp
SqlType' (SqlType -> SqlTypeExp) -> SqlType -> SqlTypeExp
forall a b. (a -> b) -> a -> b
$ Text -> SqlType
SqlOther Text
"Composite Reference"
                    ReferenceDef
_ ->
                        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 = FieldDef -> FieldType
fieldType FieldDef
field

-- | Create data types and appropriate 'PersistEntity' instances for the given
-- 'EntityDef's. Works well with the persist quasi-quoter.
mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkPersist MkPersistSettings
mps [EntityDef]
ents' = do
    [[Extension]] -> Q ()
requireExtensions
        [ [Extension
TypeFamilies], [Extension
GADTs, Extension
ExistentialQuantification]
        , [Extension
DerivingStrategies], [Extension
GeneralizedNewtypeDeriving], [Extension
StandaloneDeriving]
        , [Extension
UndecidableInstances], [Extension
DataKinds], [Extension
FlexibleInstances]
        ]
    [Dec]
persistFieldDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (EntityDef -> Q [Dec]) -> [EntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps) [EntityDef]
ents
    [Dec]
entityDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (EntityDef -> Q [Dec]) -> [EntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
mkEntity EntityMap
entityMap MkPersistSettings
mps) [EntityDef]
ents
    [Dec]
jsonDecs <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (EntityDef -> Q [Dec]) -> [EntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityDef -> Q [Dec]
mkJSON MkPersistSettings
mps) [EntityDef]
ents
    [Dec]
uniqueKeyInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (EntityDef -> Q [Dec]) -> [EntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityDef -> Q [Dec]
mkUniqueKeyInstances MkPersistSettings
mps) [EntityDef]
ents
    [Dec]
symbolToFieldInstances <- ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (EntityDef -> Q [Dec]) -> [EntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityDef -> Q [Dec]
mkSymbolToFieldInstances MkPersistSettings
mps) [EntityDef]
ents
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat
        [ [Dec]
persistFieldDecs
        , [Dec]
entityDecs
        , [Dec]
jsonDecs
        , [Dec]
uniqueKeyInstances
        , [Dec]
symbolToFieldInstances
        ]
  where
    ents :: [EntityDef]
ents = (EntityDef -> EntityDef) -> [EntityDef] -> [EntityDef]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> EntityDef
fixEntityDef [EntityDef]
ents'
    entityMap :: EntityMap
entityMap = [EntityDef] -> EntityMap
constructEntityMap [EntityDef]
ents

-- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'.
-- For example, strip out any fields marked as MigrationOnly.
fixEntityDef :: EntityDef -> EntityDef
fixEntityDef :: EntityDef -> EntityDef
fixEntityDef EntityDef
ed =
    EntityDef
ed { entityFields :: [FieldDef]
entityFields = (FieldDef -> Bool) -> [FieldDef] -> [FieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter FieldDef -> Bool
keepField ([FieldDef] -> [FieldDef]) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
ed }
  where
    keepField :: FieldDef -> Bool
keepField FieldDef
fd = FieldAttr
FieldAttrMigrationOnly FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd Bool -> Bool -> Bool
&&
                   FieldAttr
FieldAttrSafeToRemove FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd

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

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

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

-- | 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

recNameNoUnderscore :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameNoUnderscore :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameNoUnderscore MkPersistSettings
mps EntityNameHS
entName FieldNameHS
fieldName
  | MkPersistSettings -> Bool
mpsPrefixFields MkPersistSettings
mps = Text -> Text
lowerFirst (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
modifier (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName) (Text -> Text
upperFirst Text
ft)
  | Bool
otherwise           = Text -> Text
lowerFirst Text
ft
  where
    modifier :: Text -> Text -> Text
modifier = MkPersistSettings -> Text -> Text -> Text
mpsFieldLabelModifier MkPersistSettings
mps
    ft :: Text
ft = FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldName

recNameF :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameF :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameF MkPersistSettings
mps EntityNameHS
entName FieldNameHS
fieldName =
    Text -> Text
addUnderscore (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameNoUnderscore MkPersistSettings
mps EntityNameHS
entName FieldNameHS
fieldName
  where
    addUnderscore :: Text -> Text
addUnderscore
        | MkPersistSettings -> Bool
mpsGenerateLenses MkPersistSettings
mps = (Text
"_" Text -> Text -> Text
++)
        | Bool
otherwise = Text -> Text
forall a. a -> a
id

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 -> EntityDef -> Q Dec
dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec
dataTypeDec MkPersistSettings
mps EntityDef
entDef = do
    let entityInstances :: [Name]
entityInstances     = (Text -> Name) -> [Text] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) ([Text] -> [Name]) -> [Text] -> [Name]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [Text]
entityDerives EntityDef
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
        names :: [Name]
names               = [Name]
entityInstances [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name]
additionalInstances

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

    stockClasses :: Set Name
stockClasses =
        [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ((String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map 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
        ]
        )
    mkCol :: EntityNameHS -> FieldDef -> (Name, Bang, Type)
mkCol EntityNameHS
x fd :: FieldDef
fd@FieldDef {Bool
[FieldAttr]
Maybe Text
SqlType
FieldCascade
ReferenceDef
FieldNameHS
FieldNameDB
FieldType
fieldGenerated :: Maybe Text
fieldComments :: Maybe Text
fieldCascade :: FieldCascade
fieldReference :: ReferenceDef
fieldStrict :: Bool
fieldAttrs :: [FieldAttr]
fieldSqlType :: SqlType
fieldType :: FieldType
fieldDB :: FieldNameDB
fieldHaskell :: FieldNameHS
fieldGenerated :: FieldDef -> Maybe Text
fieldComments :: FieldDef -> Maybe Text
fieldCascade :: FieldDef -> FieldCascade
fieldStrict :: FieldDef -> Bool
fieldAttrs :: FieldDef -> [FieldAttr]
fieldSqlType :: FieldDef -> SqlType
fieldType :: FieldDef -> FieldType
fieldDB :: FieldDef -> FieldNameDB
fieldHaskell :: FieldDef -> FieldNameHS
fieldReference :: FieldDef -> ReferenceDef
..} =
        (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
$ MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameF MkPersistSettings
mps EntityNameHS
x FieldNameHS
fieldHaskell,
         if Bool
fieldStrict then Bang
isStrict else Bang
notStrict,
         MkPersistSettings
-> FieldDef -> Maybe Name -> Maybe IsNullable -> Type
maybeIdType MkPersistSettings
mps FieldDef
fd Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing
        )
    (Name
nameFinal, [TyVarBndr]
paramsFinal)
        | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps = (Name
nameG, [Name -> TyVarBndr
PlainTV Name
backend])
        | Bool
otherwise = (Name
name, [])
    nameG :: Name
nameG = 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
$ EntityNameHS -> Text
unEntityNameHS (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) Text -> Text -> Text
++ Text
"Generic"
    name :: Name
name = 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
$ EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef
    cols :: [(Name, Bang, Type)]
cols = (FieldDef -> (Name, Bang, Type))
-> [FieldDef] -> [(Name, Bang, Type)]
forall a b. (a -> b) -> [a] -> [b]
map (EntityNameHS -> FieldDef -> (Name, Bang, Type)
mkCol (EntityNameHS -> FieldDef -> (Name, Bang, Type))
-> EntityNameHS -> FieldDef -> (Name, Bang, Type)
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) ([FieldDef] -> [(Name, Bang, Type)])
-> [FieldDef] -> [(Name, Bang, Type)]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
entDef
    backend :: Name
backend = Name
backendName

    constrs :: [Con]
constrs
        | EntityDef -> Bool
entitySum EntityDef
entDef = (FieldDef -> Con) -> [FieldDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Con
sumCon ([FieldDef] -> [Con]) -> [FieldDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
entDef
        | Bool
otherwise = [Name -> [(Name, Bang, Type)] -> Con
RecC Name
name [(Name, Bang, Type)]
cols]

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

sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
sumConstrName MkPersistSettings
mps EntityDef
entDef FieldDef {Bool
[FieldAttr]
Maybe Text
SqlType
FieldCascade
ReferenceDef
FieldNameHS
FieldNameDB
FieldType
fieldGenerated :: Maybe Text
fieldComments :: Maybe Text
fieldCascade :: FieldCascade
fieldReference :: ReferenceDef
fieldStrict :: Bool
fieldAttrs :: [FieldAttr]
fieldSqlType :: SqlType
fieldType :: FieldType
fieldDB :: FieldNameDB
fieldHaskell :: FieldNameHS
fieldGenerated :: FieldDef -> Maybe Text
fieldComments :: FieldDef -> Maybe Text
fieldCascade :: FieldDef -> FieldCascade
fieldStrict :: FieldDef -> Bool
fieldAttrs :: FieldDef -> [FieldAttr]
fieldSqlType :: FieldDef -> SqlType
fieldType :: FieldDef -> FieldType
fieldDB :: FieldDef -> FieldNameDB
fieldHaskell :: FieldDef -> FieldNameHS
fieldReference :: FieldDef -> ReferenceDef
..} = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
name
    where
        name :: Text
name
            | MkPersistSettings -> Bool
mpsPrefixFields MkPersistSettings
mps = Text
modifiedName Text -> Text -> Text
++ Text
"Sum"
            | Bool
otherwise           = Text
fieldName Text -> Text -> Text
++ Text
"Sum"
        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
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef
        fieldName :: Text
fieldName    = Text -> Text
upperFirst (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldHaskell

uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec
uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec
uniqueTypeDec MkPersistSettings
mps EntityDef
entDef =
#if MIN_VERSION_template_haskell(2,15,0)
    Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing
        (Type -> Type -> Type
AppT (Name -> Type
ConT ''Unique) (MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) Type
backendT))
            Maybe Type
forall a. Maybe a
Nothing
            ((UniqueDef -> Con) -> [UniqueDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (MkPersistSettings -> EntityDef -> UniqueDef -> Con
mkUnique MkPersistSettings
mps EntityDef
entDef) ([UniqueDef] -> [Con]) -> [UniqueDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques EntityDef
entDef)
            []
#else
    DataInstD [] ''Unique
        [genericDataType mps (entityHaskell entDef) backendT]
            Nothing
            (map (mkUnique mps entDef) $ entityUniques entDef)
            []
#endif

mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
mkUnique MkPersistSettings
mps EntityDef
entDef (UniqueDef (ConstraintNameHS Text
constr) ConstraintNameDB
_ [(FieldNameHS, FieldNameDB)]
fields [Text]
attrs) =
    Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
constr) [BangType]
types
  where
    types :: [BangType]
types =
      ((FieldNameHS, FieldNameDB) -> BangType)
-> [(FieldNameHS, FieldNameDB)] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldDef, IsNullable) -> BangType
go ((FieldDef, IsNullable) -> BangType)
-> ((FieldNameHS, FieldNameDB) -> (FieldDef, IsNullable))
-> (FieldNameHS, FieldNameDB)
-> BangType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [FieldDef] -> (FieldDef, IsNullable))
-> [FieldDef] -> Text -> (FieldDef, IsNullable)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [FieldDef] -> (FieldDef, IsNullable)
lookup3 (EntityDef -> [FieldDef]
entityFields EntityDef
entDef) (Text -> (FieldDef, IsNullable))
-> ((FieldNameHS, FieldNameDB) -> Text)
-> (FieldNameHS, FieldNameDB)
-> (FieldDef, IsNullable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> ((FieldNameHS, FieldNameDB) -> FieldNameHS)
-> (FieldNameHS, FieldNameDB)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameHS
forall a b. (a, b) -> a
fst) [(FieldNameHS, FieldNameDB)]
fields

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

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

    lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable)
    lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable)
lookup3 Text
s [] =
        String -> (FieldDef, IsNullable)
forall a. HasCallStack => String -> a
error (String -> (FieldDef, IsNullable))
-> String -> (FieldDef, 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
++ Text
s Text -> Text -> Text
++ Text
" in unique " Text -> Text -> Text
++ Text
constr
    lookup3 Text
x (fd :: FieldDef
fd@FieldDef {Bool
[FieldAttr]
Maybe Text
SqlType
FieldCascade
ReferenceDef
FieldNameHS
FieldNameDB
FieldType
fieldGenerated :: Maybe Text
fieldComments :: Maybe Text
fieldCascade :: FieldCascade
fieldReference :: ReferenceDef
fieldStrict :: Bool
fieldAttrs :: [FieldAttr]
fieldSqlType :: SqlType
fieldType :: FieldType
fieldDB :: FieldNameDB
fieldHaskell :: FieldNameHS
fieldGenerated :: FieldDef -> Maybe Text
fieldComments :: FieldDef -> Maybe Text
fieldCascade :: FieldDef -> FieldCascade
fieldStrict :: FieldDef -> Bool
fieldAttrs :: FieldDef -> [FieldAttr]
fieldSqlType :: FieldDef -> SqlType
fieldType :: FieldDef -> FieldType
fieldDB :: FieldDef -> FieldNameDB
fieldHaskell :: FieldDef -> FieldNameHS
fieldReference :: FieldDef -> ReferenceDef
..}:[FieldDef]
rest)
        | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== FieldNameHS -> Text
unFieldNameHS FieldNameHS
fieldHaskell = (FieldDef
fd, [FieldAttr] -> IsNullable
nullable [FieldAttr]
fieldAttrs)
        | Bool
otherwise = Text -> [FieldDef] -> (FieldDef, IsNullable)
lookup3 Text
x [FieldDef]
rest

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

maybeIdType :: MkPersistSettings
           -> FieldDef
           -> Maybe Name -- ^ backend
           -> Maybe IsNullable
           -> Type
maybeIdType :: MkPersistSettings
-> FieldDef -> Maybe Name -> Maybe IsNullable -> Type
maybeIdType MkPersistSettings
mps FieldDef
fieldDef Maybe Name
mbackend Maybe IsNullable
mnull = Bool -> Type -> Type
maybeTyp Bool
mayNullable Type
idtyp
  where
    mayNullable :: Bool
mayNullable = case Maybe IsNullable
mnull of
        (Just (Nullable WhyNullable
ByMaybeAttr)) -> Bool
True
        Maybe IsNullable
_ -> FieldDef -> Bool
maybeNullable FieldDef
fieldDef
    idtyp :: Type
idtyp = MkPersistSettings -> FieldDef -> Maybe Name -> Type
idType MkPersistSettings
mps FieldDef
fieldDef Maybe Name
mbackend

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

genericDataType :: MkPersistSettings
                -> EntityNameHS
                -> Type -- ^ backend
                -> Type
genericDataType :: MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityNameHS Text
typ') Type
backend
    | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps = Name -> Type
ConT (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
typ' Text -> Text -> Text
++ Text
"Generic") Type -> Type -> Type
`AppT` Type
backend
    | 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
unpack Text
typ'

idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type
idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type
idType MkPersistSettings
mps FieldDef
fieldDef Maybe Name
mbackend =
    case FieldDef -> Maybe EntityNameHS
foreignReference FieldDef
fieldDef of
        Just EntityNameHS
typ ->
            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)
        Maybe EntityNameHS
Nothing -> FieldType -> Type
ftToType (FieldType -> Type) -> FieldType -> Type
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
fieldDef

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

mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec
mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec
mkToPersistFields MkPersistSettings
mps String
constr ed :: EntityDef
ed@EntityDef { entitySum :: EntityDef -> Bool
entitySum = Bool
isSum, entityFields :: EntityDef -> [FieldDef]
entityFields = [FieldDef]
fields } = do
    [Clause]
clauses <-
        if Bool
isSum
            then [Q Clause] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Clause] -> Q [Clause]) -> [Q Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Int -> Q Clause) -> [FieldDef] -> [Int] -> [Q Clause]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldDef -> Int -> Q Clause
goSum [FieldDef]
fields [Int
1..]
            else (Clause -> [Clause]) -> Q Clause -> Q [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return Q Clause
go
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'toPersistFields [Clause]
clauses
  where
    go :: Q Clause
    go :: Q Clause
go = do
        [Name]
xs <- [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Q Name -> [Q Name]
forall a. Int -> a -> [a]
replicate Int
fieldCount (Q Name -> [Q Name]) -> Q Name -> [Q Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x"
        let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (String -> Name
mkName String
constr) ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
xs
        Exp
sp <- [|SomePersistField|]
        let bod :: Exp
bod = [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Exp -> Exp
AppE Exp
sp (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs
        Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] Exp
bod

    fieldCount :: Int
fieldCount = [FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldDef]
fields

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


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

mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues :: [UniqueDef] -> Q Dec
mkUniqueToValues [UniqueDef]
pairs = do
    [Clause]
pairs' <- (UniqueDef -> Q Clause) -> [UniqueDef] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UniqueDef -> Q Clause
go [UniqueDef]
pairs
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueToValues ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [Clause] -> [Clause]
degen [Clause]
pairs'
  where
    go :: UniqueDef -> Q Clause
    go :: UniqueDef -> Q Clause
go (UniqueDef ConstraintNameHS
constr ConstraintNameDB
_ [(FieldNameHS, FieldNameDB)]
names [Text]
_) = do
        [Name]
xs <- ((FieldNameHS, FieldNameDB) -> Q Name)
-> [(FieldNameHS, FieldNameDB)] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> (FieldNameHS, FieldNameDB) -> Q Name
forall a b. a -> b -> a
const (Q Name -> (FieldNameHS, FieldNameDB) -> Q Name)
-> Q Name -> (FieldNameHS, FieldNameDB) -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [(FieldNameHS, FieldNameDB)]
names
        let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (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
$ ConstraintNameHS -> Text
unConstraintNameHS ConstraintNameHS
constr) ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [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]
map (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]
xs
        Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] Exp
bod

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

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

mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]
mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]
mkFromPersistValues MkPersistSettings
_ entDef :: EntityDef
entDef@(EntityDef { entitySum :: EntityDef -> Bool
entitySum = Bool
False }) =
    EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause]
fromValues EntityDef
entDef Text
"fromPersistValues" Exp
entE ([FieldDef] -> Q [Clause]) -> [FieldDef] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
entDef
  where
    entE :: Exp
entE = Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
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
entName
    entName :: Text
entName = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef

mkFromPersistValues MkPersistSettings
mps entDef :: EntityDef
entDef@(EntityDef { entitySum :: EntityDef -> Bool
entitySum = Bool
True }) = do
    Exp
nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
    [Clause]
clauses <- [FieldDef] -> [FieldDef] -> Q [Clause]
mkClauses [] ([FieldDef] -> Q [Clause]) -> [FieldDef] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
entDef
    [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Clause] -> Q [Clause]) -> [Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ [Clause]
clauses [Clause] -> [Clause] -> [Clause]
forall a. Monoid a => a -> a -> a
`mappend` [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
nothing]
  where
    entName :: Text
entName = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef
    mkClauses :: [FieldDef] -> [FieldDef] -> Q [Clause]
mkClauses [FieldDef]
_ [] = [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    mkClauses [FieldDef]
before (FieldDef
field:[FieldDef]
after) = do
        Name
x <- String -> Q Name
newName String
"x"
        let null' :: Pat
null' = Name -> [Pat] -> Pat
ConP 'PersistNull []
            pat :: Pat
pat = [Pat] -> Pat
ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ [[Pat]] -> [Pat]
forall a. Monoid a => [a] -> a
mconcat
                [ (FieldDef -> Pat) -> [FieldDef] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Pat -> FieldDef -> Pat
forall a b. a -> b -> a
const Pat
null') [FieldDef]
before
                , [Name -> Pat
VarP Name
x]
                , (FieldDef -> Pat) -> [FieldDef] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Pat -> FieldDef -> Pat
forall a b. a -> b -> a
const Pat
null') [FieldDef]
after
                ]
            constr :: Exp
constr = Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> EntityDef -> FieldDef -> Name
sumConstrName MkPersistSettings
mps EntityDef
entDef FieldDef
field
        Exp
fs <- [|fromPersistValue $(return $ VarE x)|]
        let guard' :: Guard
guard' = Exp -> Guard
NormalG (Exp -> Guard) -> Exp -> Guard
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'isNotNull Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x
        let clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] ([(Guard, Exp)] -> Body
GuardedB [(Guard
guard', Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
constr) Exp
fmapE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
fs))]) []
        [Clause]
clauses <- [FieldDef] -> [FieldDef] -> Q [Clause]
mkClauses (FieldDef
field FieldDef -> [FieldDef] -> [FieldDef]
forall a. a -> [a] -> [a]
: [FieldDef]
before) [FieldDef]
after
        [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Clause] -> Q [Clause]) -> [Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ Clause
clause Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: [Clause]
clauses

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

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

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

mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause]
mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause]
mkLensClauses MkPersistSettings
mps EntityDef
entDef = do
    Exp
lens' <- [|lensPTH|]
    Exp
getId <- [|entityKey|]
    Exp
setId <- [|\(Entity _ value) key -> Entity key value|]
    Exp
getVal <- [|entityVal|]
    Exp
dot <- [|(.)|]
    Name
keyVar <- String -> Q Name
newName String
"key"
    Name
valName <- String -> Q Name
newName String
"value"
    Name
xName <- String -> Q Name
newName String
"x"
    let idClause :: Clause
idClause = [Pat] -> Exp -> Clause
normalClause
            [Name -> [Pat] -> Pat
ConP (EntityDef -> Name
keyIdName EntityDef
entDef) []]
            (Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getId Exp -> Exp -> Exp
`AppE` Exp
setId)
    if EntityDef -> Bool
entitySum EntityDef
entDef
        then [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Clause] -> Q [Clause]) -> [Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ Clause
idClause Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: (FieldDef -> Clause) -> [FieldDef] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Name -> Name -> Name -> FieldDef -> Clause
toSumClause Exp
lens' Name
keyVar Name
valName Name
xName) (EntityDef -> [FieldDef]
entityFields EntityDef
entDef)
        else [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Clause] -> Q [Clause]) -> [Clause] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ Clause
idClause Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: (FieldDef -> Clause) -> [FieldDef] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Exp -> Exp -> Name -> Name -> Name -> FieldDef -> Clause
toClause Exp
lens' Exp
getVal Exp
dot Name
keyVar Name
valName Name
xName) (EntityDef -> [FieldDef]
entityFields EntityDef
entDef)
  where
    toClause :: Exp -> Exp -> Exp -> Name -> Name -> Name -> FieldDef -> Clause
toClause Exp
lens' Exp
getVal Exp
dot Name
keyVar Name
valName Name
xName FieldDef
f = [Pat] -> Exp -> Clause
normalClause
        [Name -> [Pat] -> Pat
ConP (MkPersistSettings -> EntityDef -> FieldDef -> Name
filterConName MkPersistSettings
mps EntityDef
entDef FieldDef
f) []]
        (Exp
lens' Exp -> Exp -> Exp
`AppE` Exp
getter Exp -> Exp -> Exp
`AppE` Exp
setter)
      where
        fieldName :: Name
fieldName = 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
$ MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameF MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) (FieldDef -> FieldNameHS
fieldHaskell FieldDef
f)
        getter :: Exp
getter = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fieldName) Exp
dot (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
getVal)
        setter :: Exp
setter = [Pat] -> Exp -> Exp
LamE
            [ Name -> [Pat] -> Pat
ConP 'Entity [Name -> Pat
VarP Name
keyVar, Name -> Pat
VarP Name
valName]
            , Name -> Pat
VarP Name
xName
            ]
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Entity Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
keyVar Exp -> Exp -> Exp
`AppE` Exp -> [FieldExp] -> Exp
RecUpdE
                (Name -> Exp
VarE Name
valName)
                [(Name
fieldName, Name -> Exp
VarE Name
xName)]

    toSumClause :: Exp -> Name -> Name -> Name -> FieldDef -> Clause
toSumClause Exp
lens' Name
keyVar Name
valName Name
xName FieldDef
fieldDef = [Pat] -> Exp -> Clause
normalClause
        [Name -> [Pat] -> Pat
ConP (MkPersistSettings -> EntityDef -> FieldDef -> Name
filterConName MkPersistSettings
mps EntityDef
entDef FieldDef
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 -> EntityDef -> FieldDef -> Name
sumConstrName MkPersistSettings
mps EntityDef
entDef FieldDef
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 [FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (EntityDef -> [FieldDef]
entityFields EntityDef
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 -> EntityDef -> FieldDef -> Name
sumConstrName MkPersistSettings
mps EntityDef
entDef FieldDef
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 -> EntityDef -> Q (Dec, [Dec])
mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec])
mkKeyTypeDec MkPersistSettings
mps EntityDef
entDef = do
    ([Dec]
instDecs, [Name]
i) <-
      if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
        then if Bool -> Bool
not Bool
useNewtype
               then do [Dec]
pfDec <- Q [Dec]
pfInstD
                       ([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
pfDec, [Name] -> [Name]
supplement [''Generic])
               else do [Dec]
gi <- Q [Dec]
genericNewtypeInstances
                       ([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
gi, [Name] -> [Name]
supplement [])
        else if Bool -> Bool
not Bool
useNewtype
               then do [Dec]
pfDec <- Q [Dec]
pfInstD
                       ([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
pfDec, [Name] -> [Name]
supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])
                else do
                    let allInstances :: [Name]
allInstances = [Name] -> [Name]
supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
                    if Bool
customKeyType
                      then ([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Name]
allInstances)
                      else do
                        [Dec]
bi <- Q [Dec]
backendKeyI
                        ([Dec], [Name]) -> Q ([Dec], [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
bi, [Name]
allInstances)

    Q ()
requirePersistentExtensions

    -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1"
    -- This is much better for debugging/logging purposes
    -- cf. https://github.com/yesodweb/persistent/issues/1104
    let alwaysStockStrategyTypeclasses :: [Name]
alwaysStockStrategyTypeclasses = [''Show, ''Read]
        deriveClauses :: [DerivClause]
deriveClauses = (Name -> DerivClause) -> [Name] -> [DerivClause]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
typeclass ->
            if (Bool -> Bool
not Bool
useNewtype Bool -> Bool -> Bool
|| Name
typeclass Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
alwaysStockStrategyTypeclasses)
                then Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) [(Name -> Type
ConT Name
typeclass)]
                else Maybe DerivStrategy -> Cxt -> 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 Cxt
-> 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 Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD    [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
k) Type
recordType) Maybe Type
forall a. Maybe a
Nothing [Con
dec] [DerivClause]
deriveClauses
#else
    let kd = if useNewtype
               then NewtypeInstD [] k [recordType] Nothing dec deriveClauses
               else DataInstD    [] k [recordType] Nothing [dec] deriveClauses
#endif
    (Dec, [Dec]) -> Q (Dec, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
kd, [Dec]
instDecs)
  where
    keyConE :: Exp
keyConE = EntityDef -> Exp
keyConExp EntityDef
entDef
    unKeyE :: Exp
unKeyE = EntityDef -> Exp
unKeyExp EntityDef
entDef
    dec :: Con
dec = Name -> [(Name, Bang, Type)] -> Con
RecC (EntityDef -> Name
keyConName EntityDef
entDef) (MkPersistSettings -> EntityDef -> [(Name, Bang, Type)]
keyFields MkPersistSettings
mps EntityDef
entDef)
    k :: Name
k = ''Key
    recordType :: Type
recordType = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) Type
backendT
    pfInstD :: Q [Dec]
pfInstD = -- FIXME: generate a PersistMap instead of PersistList
      [d|instance PersistField (Key $(pure recordType)) where
            toPersistValue = PersistList . keyToValues
            fromPersistValue (PersistList l) = keyFromValues l
            fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got
         instance PersistFieldSql (Key $(pure recordType)) where
            sqlType _ = SqlString
         instance ToJSON (Key $(pure recordType))
         instance FromJSON (Key $(pure recordType))
      |]

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

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

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

        if Bool
customKeyType then [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
alwaysInstances
          else ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Dec]
alwaysInstances [Dec] -> [Dec] -> [Dec]
forall a. Monoid a => a -> a -> a
`mappend`) Q [Dec]
backendKeyGenericI
      [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
instances

    useNewtype :: Bool
useNewtype = MkPersistSettings -> EntityDef -> Bool
pkNewtype MkPersistSettings
mps EntityDef
entDef
    customKeyType :: Bool
customKeyType = Bool -> Bool
not (EntityDef -> Bool
defaultIdType EntityDef
entDef) Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
useNewtype Bool -> Bool -> Bool
|| Maybe CompositeDef -> Bool
forall a. Maybe a -> Bool
isJust (EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
entDef)

    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)

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

keyIdText :: EntityDef -> Text
keyIdText :: EntityDef -> Text
keyIdText EntityDef
entDef = EntityNameHS -> Text
unEntityNameHS (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"Id"

unKeyName :: EntityDef -> Name
unKeyName :: EntityDef -> Name
unKeyName EntityDef
entDef = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"un" String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` EntityDef -> String
keyString EntityDef
entDef

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

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

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

keyConName :: EntityDef -> Name
keyConName :: EntityDef -> Name
keyConName EntityDef
entDef = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ ShowS
resolveConflict ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ EntityDef -> String
keyString EntityDef
entDef
  where
    resolveConflict :: ShowS
resolveConflict String
kn = if Bool
conflict then String
kn String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` String
"'" else String
kn
    conflict :: Bool
conflict = (FieldDef -> Bool) -> [FieldDef] -> 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 -> Bool)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell) ([FieldDef] -> Bool) -> [FieldDef] -> Bool
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
entDef

keyConExp :: EntityDef -> Exp
keyConExp :: EntityDef -> Exp
keyConExp = Name -> Exp
ConE (Name -> Exp) -> (EntityDef -> Name) -> EntityDef -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> Name
keyConName

keyString :: EntityDef -> String
keyString :: EntityDef -> String
keyString = Text -> String
unpack (Text -> String) -> (EntityDef -> Text) -> EntityDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> Text
keyText

keyText :: EntityDef -> Text
keyText :: EntityDef -> Text
keyText EntityDef
entDef = EntityNameHS -> Text
unEntityNameHS (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) Text -> Text -> Text
++ Text
"Key"

-- | Returns 'True' if the key definition has more than 1 field.
--
-- @since 2.11.0.0
pkNewtype :: MkPersistSettings -> EntityDef -> Bool
pkNewtype :: MkPersistSettings -> EntityDef -> Bool
pkNewtype MkPersistSettings
mps EntityDef
entDef = [(Name, Bang, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (MkPersistSettings -> EntityDef -> [(Name, Bang, Type)]
keyFields MkPersistSettings
mps EntityDef
entDef) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2

defaultIdType :: EntityDef -> Bool
defaultIdType :: EntityDef -> Bool
defaultIdType EntityDef
entDef = FieldDef -> FieldType
fieldType (EntityDef -> FieldDef
entityId EntityDef
entDef) FieldType -> FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing (EntityDef -> Text
keyIdText EntityDef
entDef)

keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]
keyFields :: MkPersistSettings -> EntityDef -> [(Name, Bang, Type)]
keyFields MkPersistSettings
mps EntityDef
entDef = case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
entDef of
  Just CompositeDef
pdef -> (FieldDef -> (Name, Bang, Type))
-> [FieldDef] -> [(Name, Bang, Type)]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> (Name, Bang, Type)
primaryKeyVar (CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)
  Maybe CompositeDef
Nothing   -> if EntityDef -> Bool
defaultIdType EntityDef
entDef
    then [Type -> (Name, Bang, Type)
idKeyVar Type
backendKeyType]
    else [Type -> (Name, Bang, Type)
idKeyVar (Type -> (Name, Bang, Type)) -> Type -> (Name, Bang, Type)
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
ftToType (FieldType -> Type) -> FieldType -> Type
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType (FieldDef -> FieldType) -> FieldDef -> FieldType
forall a b. (a -> b) -> a -> b
$ EntityDef -> FieldDef
entityId EntityDef
entDef]
  where
    backendKeyType :: Type
backendKeyType
        | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps = Name -> Type
ConT ''BackendKey Type -> Type -> Type
`AppT` Type
backendT
        | Bool
otherwise      = Name -> Type
ConT ''BackendKey Type -> Type -> Type
`AppT` MkPersistSettings -> Type
mpsBackend MkPersistSettings
mps
    idKeyVar :: Type -> (Name, Bang, Type)
idKeyVar Type
ft = (EntityDef -> Name
unKeyName EntityDef
entDef, Bang
notStrict, Type
ft)
    primaryKeyVar :: FieldDef -> (Name, Bang, Type)
primaryKeyVar FieldDef
fieldDef = ( MkPersistSettings -> EntityDef -> FieldDef -> Name
keyFieldName MkPersistSettings
mps EntityDef
entDef FieldDef
fieldDef
                       , Bang
notStrict
                       , FieldType -> Type
ftToType (FieldType -> Type) -> FieldType -> Type
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
fieldDef
                       )

keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
keyFieldName MkPersistSettings
mps EntityDef
entDef FieldDef
fieldDef
  | MkPersistSettings -> EntityDef -> Bool
pkNewtype MkPersistSettings
mps EntityDef
entDef = EntityDef -> Name
unKeyName EntityDef
entDef
  | Bool
otherwise = 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
lowerFirst (EntityDef -> Text
keyText EntityDef
entDef) Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` FieldNameHS -> Text
unFieldNameHS (FieldDef -> FieldNameHS
fieldHaskell FieldDef
fieldDef)

mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
mkKeyToValues MkPersistSettings
mps EntityDef
entDef = do
    ([Pat]
p, Exp
e) <- case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
entDef of
        Maybe CompositeDef
Nothing  ->
          ([],) (Exp -> ([Pat], Exp)) -> Q Exp -> Q ([Pat], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|(:[]) . toPersistValue . $(return $ unKeyExp entDef)|]
        Just CompositeDef
pdef ->
          ([Pat], Exp) -> Q ([Pat], Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Pat], Exp) -> Q ([Pat], Exp)) -> ([Pat], Exp) -> Q ([Pat], Exp)
forall a b. (a -> b) -> a -> b
$ CompositeDef -> ([Pat], Exp)
toValuesPrimary CompositeDef
pdef
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'keyToValues ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat]
p Exp
e
  where
    toValuesPrimary :: CompositeDef -> ([Pat], Exp)
toValuesPrimary CompositeDef
pdef =
      ( [Name -> Pat
VarP Name
recordName]
      , [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Exp) -> [FieldDef] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\FieldDef
fieldDef -> Name -> Exp
VarE 'toPersistValue Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE (MkPersistSettings -> EntityDef -> FieldDef -> Name
keyFieldName MkPersistSettings
mps EntityDef
entDef FieldDef
fieldDef) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
recordName)) ([FieldDef] -> [Exp]) -> [FieldDef] -> [Exp]
forall a b. (a -> b) -> a -> b
$ CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef
      )
    recordName :: Name
recordName = String -> Name
mkName String
"record"

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) []

mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec
mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec
mkKeyFromValues MkPersistSettings
_mps EntityDef
entDef = do
    [Clause]
clauses <- case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
entDef of
        Maybe CompositeDef
Nothing  -> do
            Exp
e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
            [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Exp -> Clause
normalClause [] Exp
e]
        Just CompositeDef
pdef ->
            EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause]
fromValues EntityDef
entDef Text
"keyFromValues" Exp
keyConE (CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'keyFromValues [Clause]
clauses
  where
    keyConE :: Exp
keyConE = EntityDef -> Exp
keyConExp EntityDef
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 a. Monoid a => a -> a -> a
`mappend` [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
xs

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

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

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

    mkPersistValue :: FieldDef -> Q Exp
mkPersistValue FieldDef
field =
        let fieldName :: Text
fieldName = (FieldNameHS -> Text
unFieldNameHS (FieldDef -> FieldNameHS
fieldHaskell FieldDef
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 :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
mkEntity EntityMap
entityMap MkPersistSettings
mps EntityDef
entDef = do
    Exp
entityDefExp <-
        if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
           then EntityMap -> EntityDef -> Q Exp
liftAndFixKeys EntityMap
entityMap EntityDef
entDef
           else MkPersistSettings -> EntityMap -> EntityDef -> Q Exp
makePersistEntityDefExp MkPersistSettings
mps EntityMap
entityMap EntityDef
entDef
    let nameT :: Text
nameT = EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName
    let nameS :: String
nameS = Text -> String
unpack Text
nameT
    let clazz :: Type
clazz = Name -> Type
ConT ''PersistEntity Type -> Type -> Type
`AppT` Type
genDataType
    Dec
tpf <- MkPersistSettings -> String -> EntityDef -> Q Dec
mkToPersistFields MkPersistSettings
mps String
nameS EntityDef
entDef
    [Clause]
fpv <- MkPersistSettings -> EntityDef -> Q [Clause]
mkFromPersistValues MkPersistSettings
mps EntityDef
entDef
    Dec
utv <- [UniqueDef] -> Q Dec
mkUniqueToValues ([UniqueDef] -> Q Dec) -> [UniqueDef] -> Q Dec
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques EntityDef
entDef
    Dec
puk <- EntityDef -> Q Dec
mkUniqueKeys EntityDef
entDef
    let primaryField :: FieldDef
primaryField = EntityDef -> FieldDef
entityId EntityDef
entDef
    [(Con, Clause)]
fields <- (FieldDef -> Q (Con, Clause)) -> [FieldDef] -> Q [(Con, Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause)
mkField MkPersistSettings
mps EntityDef
entDef) ([FieldDef] -> Q [(Con, Clause)])
-> [FieldDef] -> Q [(Con, Clause)]
forall a b. (a -> b) -> a -> b
$ FieldDef
primaryField FieldDef -> [FieldDef] -> [FieldDef]
forall a. a -> [a] -> [a]
: EntityDef -> [FieldDef]
entityFields EntityDef
entDef
    [[Dec]]
fkc <- (ForeignDef -> Q [Dec]) -> [ForeignDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
mkForeignKeysComposite MkPersistSettings
mps EntityDef
entDef) ([ForeignDef] -> Q [[Dec]]) -> [ForeignDef] -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [ForeignDef]
entityForeigns EntityDef
entDef

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

    (Dec
keyTypeDec, [Dec]
keyInstanceDecs) <- MkPersistSettings -> EntityDef -> Q (Dec, [Dec])
mkKeyTypeDec MkPersistSettings
mps EntityDef
entDef
    Dec
keyToValues' <- MkPersistSettings -> EntityDef -> Q Dec
mkKeyToValues MkPersistSettings
mps EntityDef
entDef
    Dec
keyFromValues' <- MkPersistSettings -> EntityDef -> Q Dec
mkKeyFromValues MkPersistSettings
mps EntityDef
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 (String -> Name
mkName String
nameS) [] (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 -> EntityDef -> Q [Clause]
mkLensClauses MkPersistSettings
mps EntityDef
entDef

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

    [Dec
keyFromRecordM'] <-
        case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
entDef of
            Just CompositeDef
prim -> do
                Name
recordName <- String -> Q Name
newName String
"record"
                let keyCon :: Name
keyCon = EntityDef -> Name
keyConName EntityDef
entDef
                    keyFields' :: [Name]
keyFields' =
                        (FieldDef -> Name) -> [FieldDef] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (FieldDef -> String) -> FieldDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (FieldDef -> Text) -> FieldDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameF MkPersistSettings
mps EntityNameHS
entName (FieldNameHS -> Text)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell)
                            (CompositeDef -> [FieldDef]
compositeFields CompositeDef
prim)
                    constr :: Exp
constr =
                        (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                            Exp -> Exp -> Exp
AppE
                            (Name -> Exp
ConE Name
keyCon)
                            ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map
                                (\Name
n ->
                                    Name -> Exp
VarE Name
n Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
recordName
                                )
                                [Name]
keyFields'
                            )
                    keyFromRec :: Q Pat
keyFromRec = Name -> Q Pat
varP 'keyFromRecordM
                [d|$(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr)) |]

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

    Dec
dtd <- MkPersistSettings -> EntityDef -> Q Dec
dataTypeDec MkPersistSettings
mps EntityDef
entDef
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec] -> [Dec]
addSyn ([Dec] -> [Dec]) -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$
       Dec
dtd Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat [[Dec]]
fkc [Dec] -> [Dec] -> [Dec]
forall a. Monoid a => a -> a -> a
`mappend`
      ([ Name -> [TyVarBndr] -> Type -> Dec
TySynD (EntityDef -> Name
keyIdName EntityDef
entDef) [] (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$
            Name -> Type
ConT ''Key Type -> Type -> Type
`AppT` Name -> Type
ConT (String -> Name
mkName String
nameS)
      , Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
instanceConstraint Type
clazz
        [ MkPersistSettings -> EntityDef -> Dec
uniqueTypeDec MkPersistSettings
mps EntityDef
entDef
        , Dec
keyTypeDec
        , Dec
keyToValues'
        , Dec
keyFromValues'
        , Dec
keyFromRecordM'
        , Name -> [Clause] -> Dec
FunD 'entityDef [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
entityDefExp]
        , Dec
tpf
        , Name -> [Clause] -> Dec
FunD 'fromPersistValues [Clause]
fpv
        , Dec
toFieldNames
        , Dec
utv
        , Dec
puk
#if MIN_VERSION_template_haskell(2,15,0)
        , Cxt
-> 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, Clause) -> Con) -> [(Con, Clause)] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (Con, Clause) -> Con
forall a b. (a, b) -> a
fst [(Con, Clause)]
fields)
            []
#else
        , DataInstD
            []
            ''EntityField
            [ genDataType
            , VarT $ mkName "typ"
            ]
            Nothing
            (map fst fields)
            []
#endif
        , Name -> [Clause] -> Dec
FunD 'persistFieldDef (((Con, Clause) -> Clause) -> [(Con, Clause)] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Con, Clause) -> Clause
forall a b. (a, b) -> b
snd [(Con, Clause)]
fields)
#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
$ EntityDef -> Name
keyIdName EntityDef
entDef)]
        , Name -> [Clause] -> Dec
FunD 'fieldLens [Clause]
lensClauses
        ]
      ] [Dec] -> [Dec] -> [Dec]
forall a. Monoid a => a -> a -> a
`mappend` [Dec]
lenses) [Dec] -> [Dec] -> [Dec]
forall a. Monoid a => a -> a -> a
`mappend` [Dec]
keyInstanceDecs
  where
    genDataType :: Type
genDataType = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps EntityNameHS
entName Type
backendT
    entName :: EntityNameHS
entName = EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef

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

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

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

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

    mkOnlyUniqueError :: Q Cxt -> Q [Dec]
    mkOnlyUniqueError :: Q Cxt -> Q [Dec]
mkOnlyUniqueError Q Cxt
mkCtx = do
        Cxt
ctx <- Q Cxt
mkCtx
        let impl :: [Dec]
impl = Name -> [Dec]
mkImpossible Name
onlyUniquePName
        [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
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
        Cxt
cxt <- Q Cxt
typeErrorMultipleCtx
        [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
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) []]]
        Cxt
cxt <- Q Cxt
withPersistStoreWriteCxt
        [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
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) []]]
        Cxt
cxt <- Q Cxt
withPersistStoreWriteCxt
        [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
cxt Type
atLeastOneUniqueKeyClass [Dec]
impl]

    genDataType :: Type
genDataType = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) Type
backendT

entityText :: EntityDef -> Text
entityText :: EntityDef -> Text
entityText = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (EntityDef -> EntityNameHS) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell

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

mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
mkForeignKeysComposite MkPersistSettings
mps EntityDef
entDef ForeignDef {Bool
[((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
[Text]
FieldCascade
ConstraintNameHS
ConstraintNameDB
EntityNameHS
EntityNameDB
foreignToPrimary :: ForeignDef -> Bool
foreignNullable :: ForeignDef -> Bool
foreignAttrs :: ForeignDef -> [Text]
foreignFields :: ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFieldCascade :: ForeignDef -> FieldCascade
foreignConstraintNameDBName :: ForeignDef -> ConstraintNameDB
foreignConstraintNameHaskell :: ForeignDef -> ConstraintNameHS
foreignRefTableDBName :: ForeignDef -> EntityNameDB
foreignRefTableHaskell :: ForeignDef -> EntityNameHS
foreignToPrimary :: Bool
foreignNullable :: Bool
foreignAttrs :: [Text]
foreignFields :: [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFieldCascade :: FieldCascade
foreignConstraintNameDBName :: ConstraintNameDB
foreignConstraintNameHaskell :: ConstraintNameHS
foreignRefTableDBName :: EntityNameDB
foreignRefTableHaskell :: EntityNameHS
..} =
    if Bool -> Bool
not Bool
foreignToPrimary then [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
    let fieldName :: FieldNameHS -> Name
fieldName FieldNameHS
f = 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
$ MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text
recNameF MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) FieldNameHS
f
    let fname :: Name
fname = FieldNameHS -> Name
fieldName (ConstraintNameHS -> FieldNameHS
constraintToField ConstraintNameHS
foreignConstraintNameHaskell)
    let reftableString :: String
reftableString = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
unEntityNameHS EntityNameHS
foreignRefTableHaskell
    let reftableKeyName :: Name
reftableKeyName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
reftableString String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` String
"Key"
    let tablename :: Name
tablename = 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
$ EntityDef -> Text
entityText EntityDef
entDef
    Name
recordName <- String -> Q Name
newName String
"record"

    let mkFldE :: ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB)) -> Exp
mkFldE ((FieldNameHS
foreignName, FieldNameDB
_),(FieldNameHS, FieldNameDB)
ff) = case (FieldNameHS, FieldNameDB)
ff of
          (FieldNameHS {unFieldNameHS :: FieldNameHS -> Text
unFieldNameHS = Text
"Id"}, FieldNameDB {unFieldNameDB :: FieldNameDB -> Text
unFieldNameDB = Text
"id"})
            -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"toBackendKey") (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
               Name -> Exp
VarE (FieldNameHS -> Name
fieldName FieldNameHS
foreignName) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
recordName
          (FieldNameHS, FieldNameDB)
_ -> Name -> Exp
VarE (FieldNameHS -> Name
fieldName FieldNameHS
foreignName) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
recordName
    let fldsE :: [Exp]
fldsE = (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB)) -> Exp)
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB)) -> Exp
mkFldE [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields
    let mkKeyE :: Exp
mkKeyE = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Bool -> Exp -> Exp
maybeExp Bool
foreignNullable (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
reftableKeyName) [Exp]
fldsE
    let fn :: Dec
fn = Name -> [Clause] -> Dec
FunD Name
fname [[Pat] -> Exp -> Clause
normalClause [Name -> Pat
VarP Name
recordName] Exp
mkKeyE]

    let t2 :: Type
t2 = Bool -> Type -> Type
maybeTyp Bool
foreignNullable (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)
    let sig :: Dec
sig = Name -> Type -> Dec
SigD Name
fname (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ (Type
ArrowT Type -> Type -> Type
`AppT` (Name -> Type
ConT Name
tablename)) Type -> Type -> Type
`AppT` Type
t2
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
sig, Dec
fn]

    where
        constraintToField :: ConstraintNameHS -> FieldNameHS
constraintToField = Text -> FieldNameHS
FieldNameHS (Text -> FieldNameHS)
-> (ConstraintNameHS -> Text) -> ConstraintNameHS -> FieldNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintNameHS -> Text
unConstraintNameHS

maybeExp :: Bool -> Exp -> Exp
maybeExp :: Bool -> Exp -> Exp
maybeExp Bool
may Exp
exp | Bool
may = Exp
fmapE Exp -> Exp -> Exp
`AppE` Exp
exp
                 | Bool
otherwise = Exp
exp
maybeTyp :: Bool -> Type -> Type
maybeTyp :: Bool -> Type -> Type
maybeTyp Bool
may Type
typ | Bool
may = Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Type
typ
                 | Bool
otherwise = Type
typ



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

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

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

    [PersistValue] -> Either Text record
forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues ([PersistValue] -> Either Text record)
-> [PersistValue] -> Either Text record
forall a b. (a -> b) -> a -> b
$ (String -> PersistValue) -> [String] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map 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 -> EntityDef -> Q [Dec]
persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec]
persistFieldFromEntity MkPersistSettings
mps EntityDef
entDef = do
    Exp
sqlStringConstructor' <- [|SqlString|]
    Exp
toPersistValueImplementation <- [|entityToPersistValueHelper|]
    Exp
fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|]

    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Bool -> Type -> [Dec] -> Dec
persistFieldInstanceD (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ
            [ Name -> [Clause] -> Dec
FunD 'toPersistValue [ [Pat] -> Exp -> Clause
normalClause [] Exp
toPersistValueImplementation ]
            , Name -> [Clause] -> Dec
FunD 'fromPersistValue
                [ [Pat] -> Exp -> Clause
normalClause [] Exp
fromPersistValueImplementation ]
            ]
        , Bool -> Type -> [Dec] -> Dec
persistFieldSqlInstanceD (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ
            [ Exp -> Dec
sqlTypeFunD Exp
sqlStringConstructor'
            ]
        ]
  where
    typ :: Type
typ = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entDef) Type
backendT
    entFields :: [FieldDef]
entFields = EntityDef -> [FieldDef]
entityFields EntityDef
entDef
    columnNames :: [String]
columnNames = (FieldDef -> String) -> [FieldDef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
unpack (Text -> String) -> (FieldDef -> Text) -> FieldDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell) [FieldDef]
entFields

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

-- | Save the @EntityDef@s passed in under the given name.
mkSave :: String -> [EntityDef] -> Q [Dec]
mkSave :: String -> [EntityDef] -> Q [Dec]
mkSave String
name' [EntityDef]
defs' = do
    let name :: Name
name = String -> Name
mkName String
name'
    Exp
defs <- [EntityDef] -> Q Exp
forall t. Lift t => t -> Q Exp
lift [EntityDef]
defs'
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Type -> Dec
SigD Name
name (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Type
ListT Type -> Type -> Type
`AppT` Name -> Type
ConT ''EntityDef
           , Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Exp -> Clause
normalClause [] Exp
defs]
           ]

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

-- | Generate a 'DeleteCascade' instance for the given @EntityDef@s.
mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkDeleteCascade MkPersistSettings
mps [EntityDef]
defs = do
    let deps :: [Dep]
deps = (EntityDef -> [Dep]) -> [EntityDef] -> [Dep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EntityDef -> [Dep]
getDeps [EntityDef]
defs
    (EntityDef -> Q Dec) -> [EntityDef] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Dep] -> EntityDef -> Q Dec
go [Dep]
deps) [EntityDef]
defs
  where
    getDeps :: EntityDef -> [Dep]
    getDeps :: EntityDef -> [Dep]
getDeps EntityDef
def =
        (FieldDef -> [Dep]) -> [FieldDef] -> [Dep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FieldDef -> [Dep]
getDeps' ([FieldDef] -> [Dep]) -> [FieldDef] -> [Dep]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields (EntityDef -> [FieldDef]) -> EntityDef -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityDef
fixEntityDef EntityDef
def
      where
        getDeps' :: FieldDef -> [Dep]
        getDeps' :: FieldDef -> [Dep]
getDeps' field :: FieldDef
field@FieldDef {Bool
[FieldAttr]
Maybe Text
SqlType
FieldCascade
ReferenceDef
FieldNameHS
FieldNameDB
FieldType
fieldGenerated :: Maybe Text
fieldComments :: Maybe Text
fieldCascade :: FieldCascade
fieldReference :: ReferenceDef
fieldStrict :: Bool
fieldAttrs :: [FieldAttr]
fieldSqlType :: SqlType
fieldType :: FieldType
fieldDB :: FieldNameDB
fieldHaskell :: FieldNameHS
fieldGenerated :: FieldDef -> Maybe Text
fieldComments :: FieldDef -> Maybe Text
fieldCascade :: FieldDef -> FieldCascade
fieldStrict :: FieldDef -> Bool
fieldAttrs :: FieldDef -> [FieldAttr]
fieldSqlType :: FieldDef -> SqlType
fieldType :: FieldDef -> FieldType
fieldDB :: FieldDef -> FieldNameDB
fieldHaskell :: FieldDef -> FieldNameHS
fieldReference :: FieldDef -> ReferenceDef
..} =
            case FieldDef -> Maybe EntityNameHS
foreignReference FieldDef
field of
                Just EntityNameHS
name ->
                     Dep -> [Dep]
forall (m :: * -> *) a. Monad m => a -> m a
return Dep :: EntityNameHS -> EntityNameHS -> FieldNameHS -> IsNullable -> Dep
Dep
                        { depTarget :: EntityNameHS
depTarget = EntityNameHS
name
                        , depSourceTable :: EntityNameHS
depSourceTable = EntityDef -> EntityNameHS
entityHaskell EntityDef
def
                        , depSourceField :: FieldNameHS
depSourceField = FieldNameHS
fieldHaskell
                        , depSourceNull :: IsNullable
depSourceNull  = [FieldAttr] -> IsNullable
nullable [FieldAttr]
fieldAttrs
                        }
                Maybe EntityNameHS
Nothing -> []
    go :: [Dep] -> EntityDef -> Q Dec
    go :: [Dep] -> EntityDef -> Q Dec
go [Dep]
allDeps EntityDef{entityHaskell :: EntityDef -> EntityNameHS
entityHaskell = EntityNameHS
name} = do
        let deps :: [Dep]
deps = (Dep -> Bool) -> [Dep] -> [Dep]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Dep
x -> Dep -> EntityNameHS
depTarget Dep
x EntityNameHS -> EntityNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== EntityNameHS
name) [Dep]
allDeps
        Name
key <- String -> Q Name
newName String
"key"
        let del :: Exp
del = Name -> Exp
VarE 'delete
        let dcw :: Exp
dcw = Name -> Exp
VarE 'deleteCascadeWhere
        Exp
just <- [|Just|]
        Exp
filt <- [|Filter|]
        Exp
eq <- [|Eq|]
        Exp
value <- [|FilterValue|]
        let mkStmt :: Dep -> Stmt
            mkStmt :: Dep -> Stmt
mkStmt Dep
dep = Exp -> Stmt
NoBindS
                (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp
dcw Exp -> Exp -> Exp
`AppE`
                  [Exp] -> Exp
ListE
                    [ Exp
filt Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
filtName
                           Exp -> Exp -> Exp
`AppE` (Exp
value Exp -> Exp -> Exp
`AppE` IsNullable -> Exp
val (Dep -> IsNullable
depSourceNull Dep
dep))
                           Exp -> Exp -> Exp
`AppE` Exp
eq
                    ]
              where
                filtName :: Name
filtName = MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps (Dep -> EntityNameHS
depSourceTable Dep
dep) (Dep -> FieldNameHS
depSourceField Dep
dep)
                val :: IsNullable -> Exp
val (Nullable WhyNullable
ByMaybeAttr) = Exp
just Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
key
                val IsNullable
_                      =             Name -> Exp
VarE Name
key



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

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

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

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

mkUniqueKeys :: EntityDef -> Q Dec
mkUniqueKeys :: EntityDef -> Q Dec
mkUniqueKeys EntityDef
def | EntityDef -> Bool
entitySum EntityDef
def =
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [[Pat] -> Exp -> Clause
normalClause [Pat
WildP] ([Exp] -> Exp
ListE [])]
mkUniqueKeys EntityDef
def = do
    Clause
c <- Q Clause
clause
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD 'persistUniqueKeys [Clause
c]
  where
    clause :: Q Clause
clause = do
        [(FieldNameHS, Name)]
xs <- [FieldDef]
-> (FieldDef -> Q (FieldNameHS, Name)) -> Q [(FieldNameHS, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EntityDef -> [FieldDef]
entityFields EntityDef
def) ((FieldDef -> Q (FieldNameHS, Name)) -> Q [(FieldNameHS, Name)])
-> (FieldDef -> Q (FieldNameHS, Name)) -> Q [(FieldNameHS, Name)]
forall a b. (a -> b) -> a -> b
$ \FieldDef
fieldDef -> do
            let x :: FieldNameHS
x = FieldDef -> FieldNameHS
fieldHaskell FieldDef
fieldDef
            Name
x' <- String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
unpack (FieldNameHS -> Text
unFieldNameHS FieldNameHS
x)
            (FieldNameHS, Name) -> Q (FieldNameHS, Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldNameHS
x, Name
x')
        let pcs :: [Exp]
pcs = (UniqueDef -> Exp) -> [UniqueDef] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([(FieldNameHS, Name)] -> UniqueDef -> Exp
go [(FieldNameHS, Name)]
xs) ([UniqueDef] -> [Exp]) -> [UniqueDef] -> [Exp]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [UniqueDef]
entityUniques EntityDef
def
        let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP
                (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
$ EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
def)
                (((FieldNameHS, Name) -> Pat) -> [(FieldNameHS, Name)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Pat
VarP (Name -> Pat)
-> ((FieldNameHS, Name) -> Name) -> (FieldNameHS, Name) -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, Name) -> Name
forall a b. (a, b) -> b
snd) [(FieldNameHS, Name)]
xs)
        Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause [Pat
pat] ([Exp] -> Exp
ListE [Exp]
pcs)

    go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
    go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
go [(FieldNameHS, Name)]
xs (UniqueDef ConstraintNameHS
name ConstraintNameDB
_ [(FieldNameHS, FieldNameDB)]
cols [Text]
_) =
        (Exp -> FieldNameHS -> Exp) -> Exp -> [FieldNameHS] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
go' [(FieldNameHS, Name)]
xs) (Name -> Exp
ConE (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
$ ConstraintNameHS -> Text
unConstraintNameHS ConstraintNameHS
name)) (((FieldNameHS, FieldNameDB) -> FieldNameHS)
-> [(FieldNameHS, FieldNameDB)] -> [FieldNameHS]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameHS, FieldNameDB) -> FieldNameHS
forall a b. (a, b) -> a
fst [(FieldNameHS, FieldNameDB)]
cols)

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

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

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

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

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

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

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

-- | 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.
mkMigrate :: String -> [EntityDef] -> Q [Dec]
mkMigrate :: String -> [EntityDef] -> Q [Dec]
mkMigrate String
fun [EntityDef]
allDefs = do
    Exp
body' <- Q Exp
body
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Name -> Type -> Dec
SigD (String -> Name
mkName String
fun) Type
typ
        , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
fun) [[Pat] -> Exp -> Clause
normalClause [] Exp
body']
        ]
  where
    defs :: [EntityDef]
defs = (EntityDef -> Bool) -> [EntityDef] -> [EntityDef]
forall a. (a -> Bool) -> [a] -> [a]
filter EntityDef -> Bool
isMigrated [EntityDef]
allDefs
    isMigrated :: EntityDef -> Bool
isMigrated EntityDef
def = Text
"no-migrate" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` EntityDef -> [Text]
entityAttrs EntityDef
def
    typ :: Type
typ = Name -> Type
ConT ''Migration
    entityMap :: EntityMap
entityMap = [EntityDef] -> EntityMap
constructEntityMap [EntityDef]
allDefs
    body :: Q Exp
    body :: Q Exp
body =
        case [EntityDef]
defs of
            [] -> [|return ()|]
            [EntityDef]
_  -> do
              Name
defsName <- String -> Q Name
newName String
"defs"
              Stmt
defsStmt <- do
                [Exp]
defs' <- (EntityDef -> Q Exp) -> [EntityDef] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (EntityMap -> EntityDef -> Q Exp
liftAndFixKeys EntityMap
entityMap) [EntityDef]
defs
                let defsExp :: Exp
defsExp = [Exp] -> Exp
ListE [Exp]
defs'
                Stmt -> Q Stmt
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt -> Q Stmt) -> Stmt -> Q Stmt
forall a b. (a -> b) -> a -> b
$ [Dec] -> Stmt
LetS [Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
defsName) (Exp -> Body
NormalB Exp
defsExp) []]
              [Stmt]
stmts <- (EntityDef -> Q Stmt) -> [EntityDef] -> Q [Stmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Exp -> EntityDef -> Q Stmt
toStmt (Exp -> EntityDef -> Q Stmt) -> Exp -> EntityDef -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
defsName) [EntityDef]
defs
              Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt] -> Exp
DoE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ Stmt
defsStmt Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts)
    toStmt :: Exp -> EntityDef -> Q Stmt
    toStmt :: Exp -> EntityDef -> Q Stmt
toStmt Exp
defsExp EntityDef
ed = do
        Exp
u <- EntityMap -> EntityDef -> Q Exp
liftAndFixKeys EntityMap
entityMap EntityDef
ed
        Exp
m <- [|migrate|]
        Stmt -> Q Stmt
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt -> Q Stmt) -> Stmt -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp
m Exp -> Exp -> Exp
`AppE` Exp
defsExp Exp -> Exp -> Exp
`AppE` Exp
u

makePersistEntityDefExp :: MkPersistSettings -> EntityMap -> EntityDef -> Q Exp
makePersistEntityDefExp :: MkPersistSettings -> EntityMap -> EntityDef -> Q Exp
makePersistEntityDefExp MkPersistSettings
mps EntityMap
entityMap entDef :: EntityDef
entDef@EntityDef{Bool
[Text]
[ForeignDef]
[UniqueDef]
[FieldDef]
Maybe Text
Map Text [[Text]]
FieldDef
EntityNameHS
EntityNameDB
entityComments :: EntityDef -> Maybe Text
entityExtra :: EntityDef -> Map Text [[Text]]
entityComments :: Maybe Text
entitySum :: Bool
entityExtra :: Map Text [[Text]]
entityDerives :: [Text]
entityForeigns :: [ForeignDef]
entityUniques :: [UniqueDef]
entityFields :: [FieldDef]
entityAttrs :: [Text]
entityId :: FieldDef
entityDB :: EntityNameDB
entityHaskell :: EntityNameHS
entityAttrs :: EntityDef -> [Text]
entityForeigns :: EntityDef -> [ForeignDef]
entityDB :: EntityDef -> EntityNameDB
entityUniques :: EntityDef -> [UniqueDef]
entitySum :: EntityDef -> Bool
entityDerives :: EntityDef -> [Text]
entityId :: EntityDef -> FieldDef
entityHaskell :: EntityDef -> EntityNameHS
entityFields :: EntityDef -> [FieldDef]
..} =
    [|EntityDef
        entityHaskell
        entityDB
        $(liftAndFixKey entityMap entityId)
        entityAttrs
        $(fieldDefReferences mps entDef entityFields)
        entityUniques
        entityForeigns
        entityDerives
        entityExtra
        entitySum
        entityComments
    |]

fieldDefReferences :: MkPersistSettings -> EntityDef -> [FieldDef] -> Q Exp
fieldDefReferences :: MkPersistSettings -> EntityDef -> [FieldDef] -> Q Exp
fieldDefReferences MkPersistSettings
mps EntityDef
entDef [FieldDef]
fieldDefs =
  ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [FieldDef] -> (FieldDef -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FieldDef]
fieldDefs ((FieldDef -> Q Exp) -> Q [Exp]) -> (FieldDef -> Q Exp) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \FieldDef
fieldDef -> do
    let fieldDefConE :: Exp
fieldDefConE = Name -> Exp
ConE (MkPersistSettings -> EntityDef -> FieldDef -> Name
filterConName MkPersistSettings
mps EntityDef
entDef FieldDef
fieldDef)
    Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'persistFieldDef Exp -> Exp -> Exp
`AppE` Exp
fieldDefConE

liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp
liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp
liftAndFixKeys EntityMap
entityMap EntityDef{Bool
[Text]
[ForeignDef]
[UniqueDef]
[FieldDef]
Maybe Text
Map Text [[Text]]
FieldDef
EntityNameHS
EntityNameDB
entityComments :: Maybe Text
entitySum :: Bool
entityExtra :: Map Text [[Text]]
entityDerives :: [Text]
entityForeigns :: [ForeignDef]
entityUniques :: [UniqueDef]
entityFields :: [FieldDef]
entityAttrs :: [Text]
entityId :: FieldDef
entityDB :: EntityNameDB
entityHaskell :: EntityNameHS
entityComments :: EntityDef -> Maybe Text
entityExtra :: EntityDef -> Map Text [[Text]]
entityAttrs :: EntityDef -> [Text]
entityForeigns :: EntityDef -> [ForeignDef]
entityDB :: EntityDef -> EntityNameDB
entityUniques :: EntityDef -> [UniqueDef]
entitySum :: EntityDef -> Bool
entityDerives :: EntityDef -> [Text]
entityId :: EntityDef -> FieldDef
entityHaskell :: EntityDef -> EntityNameHS
entityFields :: EntityDef -> [FieldDef]
..} =
    [|EntityDef
        entityHaskell
        entityDB
        $(liftAndFixKey entityMap entityId)
        entityAttrs
        $(ListE <$> mapM (liftAndFixKey entityMap) entityFields)
        entityUniques
        entityForeigns
        entityDerives
        entityExtra
        entitySum
        entityComments
    |]

liftAndFixKey :: EntityMap -> FieldDef -> Q Exp
liftAndFixKey :: EntityMap -> FieldDef -> Q Exp
liftAndFixKey EntityMap
entityMap (FieldDef FieldNameHS
a FieldNameDB
b FieldType
c SqlType
sqlTyp [FieldAttr]
e Bool
f ReferenceDef
fieldRef FieldCascade
fc Maybe Text
mcomments Maybe Text
fg) =
    [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|]
  where
    (ReferenceDef
fieldRef', Q Exp
sqlTyp') =
        (ReferenceDef, Q Exp)
-> Maybe (ReferenceDef, Q Exp) -> (ReferenceDef, Q Exp)
forall a. a -> Maybe a -> a
fromMaybe (ReferenceDef
fieldRef, SqlType -> Q Exp
forall t. Lift t => t -> Q Exp
lift SqlType
sqlTyp) (Maybe (ReferenceDef, Q Exp) -> (ReferenceDef, Q Exp))
-> Maybe (ReferenceDef, Q Exp) -> (ReferenceDef, Q Exp)
forall a b. (a -> b) -> a -> b
$
            case ReferenceDef
fieldRef of
                ForeignRef EntityNameHS
refName FieldType
_ft ->  do
                    EntityDef
ent <- EntityNameHS -> EntityMap -> Maybe EntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityNameHS
refName EntityMap
entityMap
                    case FieldDef -> ReferenceDef
fieldReference (FieldDef -> ReferenceDef) -> FieldDef -> ReferenceDef
forall a b. (a -> b) -> a -> b
$ EntityDef -> FieldDef
entityId EntityDef
ent of
                        fr :: ReferenceDef
fr@(ForeignRef EntityNameHS
_ FieldType
ft) ->
                            (ReferenceDef, Q Exp) -> Maybe (ReferenceDef, Q Exp)
forall a. a -> Maybe a
Just (ReferenceDef
fr, SqlTypeExp -> Q Exp
forall t. Lift t => t -> Q Exp
lift (SqlTypeExp -> Q Exp) -> SqlTypeExp -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldType -> SqlTypeExp
SqlTypeExp FieldType
ft)
                        ReferenceDef
_ ->
                            Maybe (ReferenceDef, Q Exp)
forall a. Maybe a
Nothing
                ReferenceDef
_ ->
                    Maybe (ReferenceDef, Q Exp)
forall a. Maybe a
Nothing

-- Ent
--   fieldName FieldType
--
-- forall . typ ~ FieldType => EntFieldName
--
-- EntFieldName = FieldDef ....
mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause)
mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause)
mkField MkPersistSettings
mps EntityDef
et FieldDef
cd = do
    let con :: Con
con = [TyVarBndr] -> Cxt -> 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 -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ MkPersistSettings
-> FieldDef -> Maybe Name -> Maybe IsNullable -> Type
maybeIdType MkPersistSettings
mps FieldDef
cd Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing]
                (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC Name
name []
    Exp
bod <- FieldDef -> Q Exp
forall t. Lift t => t -> Q Exp
lift FieldDef
cd
    let cla :: Clause
cla = [Pat] -> Exp -> Clause
normalClause
                [Name -> [Pat] -> Pat
ConP Name
name []]
                Exp
bod
    (Con, Clause) -> Q (Con, Clause)
forall (m :: * -> *) a. Monad m => a -> m a
return (Con
con, Clause
cla)
  where
    name :: Name
name = MkPersistSettings -> EntityDef -> FieldDef -> Name
filterConName MkPersistSettings
mps EntityDef
et FieldDef
cd

maybeNullable :: FieldDef -> Bool
maybeNullable :: FieldDef -> Bool
maybeNullable FieldDef
fd = [FieldAttr] -> IsNullable
nullable (FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd) IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
== WhyNullable -> IsNullable
Nullable WhyNullable
ByMaybeAttr

filterConName :: MkPersistSettings
              -> EntityDef
              -> FieldDef
              -> Name
filterConName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
filterConName MkPersistSettings
mps EntityDef
entity FieldDef
field = MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
filterConName' MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
entity) (FieldDef -> FieldNameHS
fieldHaskell FieldDef
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
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
++ 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

ftToType :: FieldType -> Type
ftToType :: FieldType -> Type
ftToType (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
unpack Text
t
-- This type is generated from the Quasi-Quoter.
-- Adding this special case avoids users needing to import Data.Int
ftToType (FTTypeCon (Just Text
"Data.Int") Text
"Int64") = Name -> Type
ConT ''Int64
ftToType (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]
ftToType (FTApp FieldType
x FieldType
y) = FieldType -> Type
ftToType FieldType
x Type -> Type -> Type
`AppT` FieldType -> Type
ftToType FieldType
y
ftToType (FTList FieldType
x) = Type
ListT Type -> Type -> Type
`AppT` FieldType -> Type
ftToType FieldType
x

infixr 5 ++
(++) :: Text -> Text -> Text
++ :: Text -> Text -> Text
(++) = Text -> Text -> Text
append

mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]
mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]
mkJSON MkPersistSettings
_ EntityDef
def | (Text
"json" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` EntityDef -> [Text]
entityAttrs EntityDef
def) = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkJSON MkPersistSettings
mps EntityDef
def = do
    [[Extension]] -> Q ()
requireExtensions [[Extension
FlexibleInstances]]
    Exp
pureE <- [|pure|]
    Exp
apE' <- [|(<*>)|]
    Exp
packE <- [|pack|]
    Exp
dotEqualE <- [|(.=)|]
    Exp
dotColonE <- [|(.:)|]
    Exp
dotColonQE <- [|(.:?)|]
    Exp
objectE <- [|object|]
    Name
obj <- String -> Q Name
newName String
"obj"
    Exp
mzeroE <- [|mzero|]

    [Name]
xs <- (FieldDef -> Q Name) -> [FieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Q Name
newName (String -> Q Name) -> (FieldDef -> String) -> FieldDef -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> String) -> (FieldDef -> Text) -> FieldDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHSForJSON (FieldNameHS -> Text)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
fieldHaskell)
        ([FieldDef] -> Q [Name]) -> [FieldDef] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
def

    let conName :: Name
conName = 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
$ EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
def
        typ :: Type
typ = MkPersistSettings -> EntityNameHS -> Type -> Type
genericDataType MkPersistSettings
mps (EntityDef -> EntityNameHS
entityHaskell EntityDef
def) Type
backendT
        toJSONI :: Dec
toJSONI = Name -> Bool -> Type -> [Dec] -> Dec
typeInstanceD ''ToJSON (MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps) Type
typ [Dec
toJSON']
        toJSON' :: Dec
toJSON' = Name -> [Clause] -> Dec
FunD 'toJSON ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Clause
normalClause
            [Name -> [Pat] -> Pat
ConP Name
conName ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
xs]
            (Exp
objectE Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
pairs)
        pairs :: [Exp]
pairs = (FieldDef -> Name -> Exp) -> [FieldDef] -> [Name] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldDef -> Name -> Exp
toPair (EntityDef -> [FieldDef]
entityFields EntityDef
def) [Name]
xs
        toPair :: FieldDef -> Name -> Exp
toPair FieldDef
f Name
x = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
            (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp
packE 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
$ FieldDef -> FieldNameHS
fieldHaskell FieldDef
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']
        parseJSON' :: Dec
parseJSON' = Name -> [Clause] -> Dec
FunD 'parseJSON
            [ [Pat] -> Exp -> Clause
normalClause [Name -> [Pat] -> Pat
ConP 'Object [Name -> Pat
VarP Name
obj]]
                ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                    (\Exp
x Exp
y -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
x) Exp
apE' (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
y))
                    (Exp
pureE Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
conName)
                    [Exp]
pulls
                )
            , [Pat] -> Exp -> Clause
normalClause [Pat
WildP] Exp
mzeroE
            ]
        pulls :: [Exp]
pulls = (FieldDef -> Exp) -> [FieldDef] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Exp
toPull ([FieldDef] -> [Exp]) -> [FieldDef] -> [Exp]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
entityFields EntityDef
def
        toPull :: FieldDef -> Exp
toPull FieldDef
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 FieldDef -> Bool
maybeNullable FieldDef
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
packE (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
$ FieldDef -> FieldNameHS
fieldHaskell FieldDef
f)
    case MkPersistSettings -> Maybe EntityJSON
mpsEntityJSON MkPersistSettings
mps of
        Maybe EntityJSON
Nothing -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
toJSONI, Dec
fromJSONI]
        Just EntityJSON
entityJSON -> do
            [Dec]
entityJSONIs <- if MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps
              then [d|
                instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where
                    toJSON = $(varE (entityToJSON entityJSON))
                instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where
                    parseJSON = $(varE (entityFromJSON entityJSON))
                |]
              else [d|
                instance ToJSON (Entity $(pure typ)) where
                    toJSON = $(varE (entityToJSON entityJSON))
                instance FromJSON (Entity $(pure typ)) where
                    parseJSON = $(varE (entityFromJSON entityJSON))
                |]
            [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
toJSONI Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
fromJSONI Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
entityJSONIs

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

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

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

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

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

-- entityUpdates :: EntityDef -> [(EntityNameHS, FieldType, IsNullable, PersistUpdate)]
-- entityUpdates =
--     concatMap go . entityFields
--   where
--     go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound]

-- mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec
-- mkToUpdate name pairs = do
--     pairs' <- mapM go pairs
--     return $ FunD (mkName name) $ degen pairs'
--   where
--     go (constr, pu) = do
--         pu' <- lift pu
--         return $ normalClause [RecP (mkName constr) []] pu'


-- mkToFieldName :: String -> [(String, String)] -> Dec
-- mkToFieldName func pairs =
--         FunD (mkName func) $ degen $ map go pairs
--   where
--     go (constr, name) =
--         normalClause [RecP (mkName constr) []] (LitE $ StringL name)

-- mkToValue :: String -> [String] -> Dec
-- mkToValue func = FunD (mkName func) . degen . map go
--   where
--     go constr =
--         let x = mkName "x"
--          in normalClause [ConP (mkName constr) [VarP x]]
--                    (VarE 'toPersistValue `AppE` VarE x)

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

mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
mkSymbolToFieldInstances MkPersistSettings
mps EntityDef
ed = do
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [FieldDef] -> (FieldDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EntityDef -> [FieldDef]
entityFields EntityDef
ed) ((FieldDef -> Q [Dec]) -> Q [[Dec]])
-> (FieldDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \FieldDef
fieldDef -> do
        let fieldNameT :: Q Type
fieldNameT =
                TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> TyLitQ
strTyLit (String -> TyLitQ) -> String -> TyLitQ
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text) -> FieldNameHS -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameHS
fieldHaskell FieldDef
fieldDef
                    :: Q Type

            nameG :: Name
nameG = 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
$ EntityNameHS -> Text
unEntityNameHS (EntityDef -> EntityNameHS
entityHaskell EntityDef
ed) Text -> Text -> Text
++ Text
"Generic"

            recordNameT :: Q Type
recordNameT
                | MkPersistSettings -> Bool
mpsGeneric MkPersistSettings
mps =
                    Name -> Q Type
conT Name
nameG Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
backendName
                | Bool
otherwise =
                    Name -> Q Type
conT (Name -> Q Type) -> Name -> Q 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 -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
ed

            fieldTypeT :: Type
fieldTypeT =
                MkPersistSettings
-> FieldDef -> Maybe Name -> Maybe IsNullable -> Type
maybeIdType MkPersistSettings
mps FieldDef
fieldDef Maybe Name
forall a. Maybe a
Nothing Maybe IsNullable
forall a. Maybe a
Nothing
            entityFieldConstr :: Q Exp
entityFieldConstr =
                Name -> Q Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ MkPersistSettings -> EntityDef -> FieldDef -> Name
filterConName MkPersistSettings
mps EntityDef
ed FieldDef
fieldDef
                    :: Q Exp
        [d|
            instance SymbolToField $(fieldNameT) $(recordNameT) $(pure fieldTypeT) where
                symbolToField = $(entityFieldConstr)
            |]

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

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