{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

module Database.Groundhog.TH.CodeGen
  ( mkEmbeddedPersistFieldInstance,
    mkEmbeddedPurePersistFieldInstance,
    mkEmbeddedInstance,
    mkEntityPhantomConstructors,
    mkEntityPhantomConstructorInstances,
    mkEntityUniqueKeysPhantoms,
    mkAutoKeyPersistFieldInstance,
    mkAutoKeyPrimitivePersistFieldInstance,
    mkUniqueKeysIsUniqueInstances,
    mkUniqueKeysEmbeddedInstances,
    mkUniqueKeysPersistFieldInstances,
    mkUniqueKeysPrimitiveOrPurePersistFieldInstances,
    mkKeyEqShowInstances,
    mkEntityPersistFieldInstance,
    mkEntitySinglePersistFieldInstance,
    mkPersistEntityInstance,
    mkEntityNeverNullInstance,
    mkPrimitivePersistFieldInstance,
    mkPrimitivePrimitivePersistFieldInstance,
    mkMigrateFunction,
  )
where

import Control.Arrow (first)
import Control.Monad (filterM, forM, forM_, liftM2, replicateM, zipWithM)
import Data.Either (lefts, rights)
import Data.List (findIndex, nub, partition)
import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe)
import Database.Groundhog.Core
import Database.Groundhog.Generic
import Database.Groundhog.TH.Settings
import qualified GHC.Read as R
import Language.Haskell.TH hiding (TyVarBndr)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax (Lift (..))
import qualified Text.ParserCombinators.ReadPrec as R
import qualified Text.Read.Lex as R

mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPersistFieldInstance THEmbeddedDef
def = do
  let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def
  let embedded :: Type
embedded = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEmbeddedDef -> Name
thEmbeddedName THEmbeddedDef
def)) [Type]
types

  Dec
persistName' <- do
    Name
v <- String -> Q Name
newName String
"v"
    let mkLambda :: Type -> ExpQ
mkLambda Type
t = [|undefined :: $(pure embedded) -> $(pure t)|]
    let paramNames :: ExpQ
paramNames = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
xs -> [|$p ++ [delim] ++ $xs|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|persistName ($(mkLambda t) $(varE v))|]) [Type]
types
    let fullEmbeddedName :: ExpQ
fullEmbeddedName =
          if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types
            then [|$(stringE $ thDbEmbeddedName def)|]
            else [|$(stringE $ thDbEmbeddedName def) ++ [delim] ++ $(paramNames)|]
    let body :: BodyQ
body = ExpQ -> BodyQ
normalB ExpQ
fullEmbeddedName
    let pat :: PatQ
pat = if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types then PatQ
wildP else Name -> PatQ
varP Name
v
    Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] BodyQ
body []]

  Dec
toPersistValues' <- do
    (PatQ
pat, ExpQ
body) <- Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def) ExpQ -> ExpQ
forall a. a -> a
id
    Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []]

  Dec
fromPersistValues' <- do
    Name
xs <- String -> Q Name
newName String
"xs"
    Name
failureName <- String -> Q Name
newName String
"failure"
    (Bool
isFailureUsed, Exp
body) <- Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues Name
failureName Name
xs (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def)
    let failureBody :: BodyQ
failureBody = ExpQ -> BodyQ
normalB [|(\a -> fail (failMessage a $(varE xs)) >> pure (a, [])) undefined|]
        failureFunc :: Q Dec
failureFunc = Name -> [ClauseQ] -> Q Dec
funD Name
failureName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
failureBody []]
        locals :: [Q Dec]
locals = if Bool
isFailureUsed then [Q Dec
failureFunc] else []
    Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
xs] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
body) [Q Dec]
locals]

  Dec
dbType' <- do
    Name
v <- String -> Q Name
newName String
"v"
    Name
proxy <- String -> Q Name
newName String
"p"
    let mkField :: Int -> THFieldDef -> ExpQ
mkField Int
fNum THFieldDef
f = do
          Name
a <- String -> Q Name
newName String
"a"
          let fname :: String
fname = THFieldDef -> String
thDbFieldName THFieldDef
f
              nvar :: ExpQ
nvar =
                if Type -> Bool
hasFreeVars (THFieldDef -> Type
thFieldType THFieldDef
f)
                  then
                    let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
fNum PatQ
wildP [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [Name -> PatQ
varP Name
a] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate ([THFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) PatQ
wildP
                     in ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
v) [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
a) []]
                  else [|undefined :: $(pure $ thFieldType f)|]
              typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
          [|(fname, $typ)|]
    let pat :: PatQ
pat = if [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr] -> Bool) -> [TyVarBndr] -> Bool
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def then PatQ
wildP else Name -> PatQ
varP Name
v
    Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, PatQ
pat] (ExpQ -> BodyQ
normalB [|DbEmbedded (EmbeddedDef False $(listE $ zipWith mkField [0 ..] $ thEmbeddedFields def)) Nothing|]) []]

  let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def)
  let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
embedded) [Dec]
decs]

mkToPersistValues :: Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues :: Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues Name
constrName [THFieldDef]
fieldDefs ExpQ -> ExpQ
processResult = do
  [Name]
patVars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
  let processField :: Name -> THFieldDef -> Q (Maybe StmtQ, ExpQ)
processField Name
fName THFieldDef
fDef = do
        Bool
isP <- Type -> Q Bool
isPrim (THFieldDef -> Type
thFieldType THFieldDef
fDef)
        let field :: ExpQ
field = (ExpQ -> ExpQ)
-> (Name -> ExpQ -> ExpQ) -> Maybe Name -> ExpQ -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ -> ExpQ
forall a. a -> a
id (\Name
convName ExpQ
x -> [|fst $(varE convName) $ $x|]) (THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef) (Name -> ExpQ
varE Name
fName)
        if Bool
isP
          then (Maybe StmtQ, ExpQ) -> Q (Maybe StmtQ, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe StmtQ
forall a. Maybe a
Nothing, [|(toPrimitivePersistValue $field :)|])
          else String -> Q Name
newName String
"x" Q Name -> (Name -> Q (Maybe StmtQ, ExpQ)) -> Q (Maybe StmtQ, ExpQ)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> (Maybe StmtQ, ExpQ) -> Q (Maybe StmtQ, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StmtQ -> Maybe StmtQ
forall a. a -> Maybe a
Just (StmtQ -> Maybe StmtQ) -> StmtQ -> Maybe StmtQ
forall a b. (a -> b) -> a -> b
$ PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
x) [|toPersistValues $field|], Name -> ExpQ
varE Name
x)
  ([StmtQ]
binds, [ExpQ]
funcs) <- ([Maybe StmtQ] -> [StmtQ])
-> ([Maybe StmtQ], [ExpQ]) -> ([StmtQ], [ExpQ])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Maybe StmtQ] -> [StmtQ]
forall a. [Maybe a] -> [a]
catMaybes (([Maybe StmtQ], [ExpQ]) -> ([StmtQ], [ExpQ]))
-> ([(Maybe StmtQ, ExpQ)] -> ([Maybe StmtQ], [ExpQ]))
-> [(Maybe StmtQ, ExpQ)]
-> ([StmtQ], [ExpQ])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Maybe StmtQ, ExpQ)] -> ([Maybe StmtQ], [ExpQ])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe StmtQ, ExpQ)] -> ([StmtQ], [ExpQ]))
-> Q [(Maybe StmtQ, ExpQ)] -> Q ([StmtQ], [ExpQ])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> THFieldDef -> Q (Maybe StmtQ, ExpQ))
-> [Name] -> [THFieldDef] -> Q [(Maybe StmtQ, ExpQ)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> THFieldDef -> Q (Maybe StmtQ, ExpQ)
processField [Name]
patVars [THFieldDef]
fieldDefs
  let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP Name
constrName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
patVars
      result :: ExpQ
result = [|pure $(processResult $ if null funcs then [|id|] else foldr1 (\a b -> [|$a . $b|]) funcs)|]
      body :: ExpQ
body = if [StmtQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StmtQ]
binds then ExpQ
result else [StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [StmtQ]
binds [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [ExpQ -> StmtQ
noBindS ExpQ
result]
  (PatQ, ExpQ) -> Q (PatQ, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatQ
pat, ExpQ
body)

mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues Name
failureName Name
values Name
constrName [THFieldDef]
fieldDefs = do
  [Name]
patVars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
  let failure :: MatchQ
failure = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
failureName) []
      mkArg :: (Name, THFieldDef) -> ExpQ
mkArg (Name
fName, THFieldDef
fDef) = do
        Bool
isP <- Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
fDef
        let x :: ExpQ
x =
              if Bool
isP
                then [|fromPrimitivePersistValue $(varE fName)|]
                else Name -> ExpQ
varE Name
fName
        ExpQ -> (Name -> ExpQ) -> Maybe Name -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ
x (\Name
convName -> [|snd $(varE convName) $ $x|]) (Maybe Name -> ExpQ) -> Maybe Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef
      result :: ExpQ
result = (ExpQ -> (Name, THFieldDef) -> ExpQ)
-> ExpQ -> [(Name, THFieldDef)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
func (Name, THFieldDef)
f -> ExpQ -> ExpQ -> ExpQ
appE ExpQ
func (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name, THFieldDef) -> ExpQ
mkArg (Name, THFieldDef)
f) (Name -> ExpQ
conE Name
constrName) ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs
      goField :: Name -> [(Name, THFieldDef)] -> ExpQ
goField Name
xs [(Name, THFieldDef)]
vars = do
        ([(Name, THFieldDef)]
fields, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Q Bool -> Q Bool)
-> ((Name, THFieldDef) -> Q Bool) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
        [Name]
xss <- (Name
xs Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:) ([Name] -> [Name]) -> Q [Name] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, THFieldDef) -> Q Name) -> [(Name, THFieldDef)] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> (Name, THFieldDef) -> Q Name
forall a b. a -> b -> a
const (Q Name -> (Name, THFieldDef) -> Q Name)
-> Q Name -> (Name, THFieldDef) -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"xs") [(Name, THFieldDef)]
fields
        let f :: Name -> Name -> (Name, b) -> StmtQ
f Name
oldXs Name
newXs (Name
fname, b
_) = PatQ -> ExpQ -> StmtQ
bindS (Name -> [PatQ] -> PatQ
conP '(,) [Name -> PatQ
varP Name
fname, Name -> PatQ
varP Name
newXs]) [|fromPersistValues $(varE oldXs)|]
            stmts :: [StmtQ]
stmts = (Name -> Name -> (Name, THFieldDef) -> StmtQ)
-> [Name] -> [Name] -> [(Name, THFieldDef)] -> [StmtQ]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> (Name, THFieldDef) -> StmtQ
forall b. Name -> Name -> (Name, b) -> StmtQ
f [Name]
xss ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
xss) [(Name, THFieldDef)]
fields
            expr :: ExpQ
expr = Name -> [(Name, THFieldDef)] -> ExpQ
goPrim ([Name] -> Name
forall a. [a] -> a
last [Name]
xss) [(Name, THFieldDef)]
rest
        [StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [StmtQ]
stmts [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [ExpQ -> StmtQ
noBindS ExpQ
expr]
      goPrim :: Name -> [(Name, THFieldDef)] -> ExpQ
goPrim Name
xs [(Name, THFieldDef)]
vars = do
        Name
xs' <- String -> Q Name
newName String
"xs"
        ([(Name, THFieldDef)]
prims, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM (Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
        let body' :: ExpQ
body' = case [(Name, THFieldDef)]
rest of
              [] -> [|pure ($result, $(varE xs'))|]
              [(Name, THFieldDef)]
_ -> Name -> [(Name, THFieldDef)] -> ExpQ
goField Name
xs' [(Name, THFieldDef)]
rest
            m :: MatchQ
m = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (((Name, THFieldDef) -> PatQ -> PatQ)
-> PatQ -> [(Name, THFieldDef)] -> PatQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Name
fName, THFieldDef
_) PatQ
p -> PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
fName) '(:) PatQ
p) (Name -> PatQ
varP Name
xs') [(Name, THFieldDef)]
prims) (ExpQ -> BodyQ
normalB ExpQ
body') []
        if [(Name, THFieldDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, THFieldDef)]
prims
          then ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m]
          else ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m, MatchQ
failure]
  Exp
body <- Name -> [(Name, THFieldDef)] -> ExpQ
goPrim Name
values ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs
  Bool
anyPrim <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (THFieldDef -> Q Bool) -> [THFieldDef] -> Q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Q Bool
isPrim (Type -> Q Bool) -> (THFieldDef -> Type) -> THFieldDef -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType) [THFieldDef]
fieldDefs
  (Bool, Exp) -> Q (Bool, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
anyPrim, Exp
body)

mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> Cxt -> Q [Dec]
mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> [Type] -> Q [Dec]
mkPurePersistFieldInstance Type
dataType Name
cName [THFieldDef]
fieldDefs [Type]
context = do
  Dec
toPurePersistValues' <- do
    [Name]
vars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
    let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP Name
cName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
vars
        body :: ExpQ
body = [(Name, THFieldDef)] -> ExpQ
mkToPurePersistValues ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vars [THFieldDef]
fieldDefs
    Name -> [ClauseQ] -> Q Dec
funD 'toPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []]

  Dec
fromPurePersistValues' <-
    let goField :: Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goField Name
xs [(Name, THFieldDef)]
vars ExpQ
result MatchQ
failure = do
          ([(Name, THFieldDef)]
fields, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Q Bool -> Q Bool)
-> ((Name, THFieldDef) -> Q Bool) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
          [Name]
xss <- (Name
xs Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:) ([Name] -> [Name]) -> Q [Name] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, THFieldDef) -> Q Name) -> [(Name, THFieldDef)] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> (Name, THFieldDef) -> Q Name
forall a b. a -> b -> a
const (Q Name -> (Name, THFieldDef) -> Q Name)
-> Q Name -> (Name, THFieldDef) -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"xs") [(Name, THFieldDef)]
fields
          let f :: Name -> Name -> (Name, b) -> Q Dec
f Name
oldXs Name
newXs (Name
fName, b
_) = PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> [PatQ] -> PatQ
conP '(,) [Name -> PatQ
varP Name
fName, Name -> PatQ
varP Name
newXs]) (ExpQ -> BodyQ
normalB [|fromPurePersistValues $(varE oldXs)|]) []
          let stmts :: [Q Dec]
stmts = (Name -> Name -> (Name, THFieldDef) -> Q Dec)
-> [Name] -> [Name] -> [(Name, THFieldDef)] -> [Q Dec]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> (Name, THFieldDef) -> Q Dec
forall b. Name -> Name -> (Name, b) -> Q Dec
f [Name]
xss ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
xss) [(Name, THFieldDef)]
fields
          (Bool
isFailureUsed, ExpQ
expr) <- Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goPrim ([Name] -> Name
forall a. [a] -> a
last [Name]
xss) [(Name, THFieldDef)]
rest ExpQ
result MatchQ
failure
          (Bool, ExpQ) -> Q (Bool, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
isFailureUsed, [Q Dec] -> ExpQ -> ExpQ
letE [Q Dec]
stmts ExpQ
expr)
        goPrim :: Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goPrim Name
xs [(Name, THFieldDef)]
vars ExpQ
result MatchQ
failure = do
          Name
xs' <- String -> Q Name
newName String
"xs"
          ([(Name, THFieldDef)]
prims, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM (Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
          (Bool
isFailureUsed, ExpQ
body') <- case [(Name, THFieldDef)]
rest of
            [] -> (Bool, ExpQ) -> Q (Bool, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [|($result, $(varE xs'))|])
            [(Name, THFieldDef)]
_ -> Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goField Name
xs' [(Name, THFieldDef)]
rest ExpQ
result MatchQ
failure
          let m :: MatchQ
m = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (((Name, THFieldDef) -> PatQ -> PatQ)
-> PatQ -> [(Name, THFieldDef)] -> PatQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Name
fName, THFieldDef
_) PatQ
p -> PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
fName) '(:) PatQ
p) (Name -> PatQ
varP Name
xs') [(Name, THFieldDef)]
prims) (ExpQ -> BodyQ
normalB ExpQ
body') []
          (Bool, ExpQ) -> Q (Bool, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, ExpQ) -> Q (Bool, ExpQ)) -> (Bool, ExpQ) -> Q (Bool, ExpQ)
forall a b. (a -> b) -> a -> b
$
            if [(Name, THFieldDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, THFieldDef)]
prims
              then (Bool
isFailureUsed, ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m])
              else (Bool
True, ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m, MatchQ
failure])
        mkArg :: (Name, THFieldDef) -> ExpQ
mkArg (Name
fName, THFieldDef
fDef) = do
          Bool
isP <- Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
fDef
          let x :: ExpQ
x =
                if Bool
isP
                  then [|fromPrimitivePersistValue $(varE fName)|]
                  else Name -> ExpQ
varE Name
fName
          ExpQ -> (Name -> ExpQ) -> Maybe Name -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ
x (\Name
convName -> [|snd $(varE convName) $ $x|]) (Maybe Name -> ExpQ) -> Maybe Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef
     in do
          Name
xs <- String -> Q Name
newName String
"xs"
          let failureBody :: BodyQ
failureBody = ExpQ -> BodyQ
normalB [|(\a -> error (failMessage a $(varE xs)) `asTypeOf` (a, [])) undefined|]
          Name
failureName <- String -> Q Name
newName String
"failure"
          [Name]
patVars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
          let failure :: MatchQ
failure = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
failureName) []
              result :: ExpQ
result = (ExpQ -> (Name, THFieldDef) -> ExpQ)
-> ExpQ -> [(Name, THFieldDef)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a (Name, THFieldDef)
f -> ExpQ -> ExpQ -> ExpQ
appE ExpQ
a (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name, THFieldDef) -> ExpQ
mkArg (Name, THFieldDef)
f) (Name -> ExpQ
conE Name
cName) ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs
          (Bool
isFailureUsed, ExpQ
start) <- Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goPrim Name
xs ([Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs) ExpQ
result MatchQ
failure
          let failureFunc :: Q Dec
failureFunc = Name -> [ClauseQ] -> Q Dec
funD Name
failureName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
failureBody []]
              locals :: [Q Dec]
locals = if Bool
isFailureUsed then [Q Dec
failureFunc] else []
          Name -> [ClauseQ] -> Q Dec
funD 'fromPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
xs] (ExpQ -> BodyQ
normalB ExpQ
start) [Q Dec]
locals]

  let decs :: [Dec]
decs = [Dec
toPurePersistValues', Dec
fromPurePersistValues']
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PurePersistField) Type
dataType) [Dec]
decs]

mkEmbeddedPurePersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPurePersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPurePersistFieldInstance THEmbeddedDef
def = do
  let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def
  let embedded :: Type
embedded = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEmbeddedDef -> Name
thEmbeddedName THEmbeddedDef
def)) [Type]
types
  let fDefs :: [THFieldDef]
fDefs = THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def
  Maybe [Type]
context <- [TyVarBndr] -> [THFieldDef] -> Q (Maybe [Type])
paramsPureContext (THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def) [THFieldDef]
fDefs
  case Maybe [Type]
context of
    Maybe [Type]
Nothing -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just [Type]
context' -> Type -> Name -> [THFieldDef] -> [Type] -> Q [Dec]
mkPurePersistFieldInstance Type
embedded (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) [THFieldDef]
fDefs [Type]
context'

mkAutoKeyPersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPersistFieldInstance THEntityDef
def = case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
  Just THAutoKeyDef
_ -> do
    let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
    Type
keyType <- [t|Key $(pure entity) BackendSpecific|]

    Dec
persistName' <- do
      Name
a <- String -> Q Name
newName String
"a"
      let body :: ExpQ
body = [|"Key" ++ [delim] ++ persistName ((undefined :: Key v u -> v) $(varE a))|]
      Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
a] (ExpQ -> BodyQ
normalB ExpQ
body) []]
    Dec
toPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToPersistValue|]) []]
    Dec
fromPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromPersistValue|]) []]
    Dec
dbType' <- do
      Name
proxy <- String -> Q Name
newName String
"p"
      Name
a <- String -> Q Name
newName String
"a"
      let e :: ExpQ
e = [|entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a))|]
          body :: ExpQ
body = [|DbTypePrimitive (getDefaultAutoKeyType $(varE proxy)) False Nothing (Just (Left ($e, Nothing), Nothing, Nothing))|]
      Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ
varP Name
a] (ExpQ -> BodyQ
normalB ExpQ
body) []]

    let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
    let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
keyType) [Dec]
decs]
  Maybe THAutoKeyDef
_ -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPrimitivePersistFieldInstance THEntityDef
def = case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
  Just THAutoKeyDef
autoKey -> do
    let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
    Type
keyType <- [t|Key $(pure entity) BackendSpecific|]
    let conName :: Name
conName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THAutoKeyDef -> String
thAutoKeyConstrName THAutoKeyDef
autoKey
    Dec
toPrim' <- do
      Name
x <- String -> Q Name
newName String
"x"
      let body :: ExpQ
body = [|$(varE x)|]
      Name -> [ClauseQ] -> Q Dec
funD 'toPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
x]] (ExpQ -> BodyQ
normalB ExpQ
body) []]
    Dec
fromPrim' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
conName) []]
    let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
    let decs :: [Dec]
decs = [Dec
toPrim', Dec
fromPrim']
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
      [ Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PrimitivePersistField) Type
keyType) [Dec]
decs,
        [Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
context Type
keyType,
        [Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
context Type
keyType
      ]
  Maybe THAutoKeyDef
_ -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkDefaultPurePersistFieldInstance :: Cxt -> Type -> Q Dec
mkDefaultPurePersistFieldInstance :: [Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
context Type
typ = do
  Dec
toPurePersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToPurePersistValues|]) []]
  Dec
fromPurePersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromPurePersistValues|]) []]
  let decs :: [Dec]
decs = [Dec
toPurePersistValues', Dec
fromPurePersistValues']
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PurePersistField) Type
typ) [Dec]
decs

mkDefaultSinglePersistFieldInstance :: Cxt -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance :: [Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
context Type
typ = do
  Dec
toSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'toSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToSinglePersistValue|]) []]
  Dec
fromSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'fromSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromSinglePersistValue|]) []]
  let decs :: [Dec]
decs = [Dec
toSinglePersistValue', Dec
fromSinglePersistValue']
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''SinglePersistField) Type
typ) [Dec]
decs

mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysIsUniqueInstances THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
  let constr :: THConstructorDef
constr = [THConstructorDef] -> THConstructorDef
forall a. [a] -> a
head ([THConstructorDef] -> THConstructorDef)
-> [THConstructorDef] -> THConstructorDef
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
  [THUniqueKeyDef] -> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q Dec) -> Q [Dec])
-> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
    Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
    Dec
extractUnique' <- do
      [(String, Name)]
uniqueFields <- (THFieldDef -> Q (String, Name))
-> [THFieldDef] -> Q [(String, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\THFieldDef
f -> String -> Q Name
newName String
"x" Q Name -> (Name -> Q (String, Name)) -> Q (String, Name)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> (String, Name) -> Q (String, Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (THFieldDef -> String
thFieldName THFieldDef
f, Name
x)) ([THFieldDef] -> Q [(String, Name)])
-> [THFieldDef] -> Q [(String, Name)]
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique
      let mkFieldPat :: THFieldDef -> PatQ
mkFieldPat THFieldDef
f = PatQ -> (Name -> PatQ) -> Maybe Name -> PatQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PatQ
wildP Name -> PatQ
varP (Maybe Name -> PatQ) -> Maybe Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> [(String, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (THFieldDef -> String
thFieldName THFieldDef
f) [(String, Name)]
uniqueFields
      let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
constr) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (THFieldDef -> PatQ) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map THFieldDef -> PatQ
mkFieldPat ([THFieldDef] -> [PatQ]) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
constr
      let body :: ExpQ
body = (ExpQ -> (String, Name) -> ExpQ)
-> ExpQ -> [(String, Name)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
expr (String, Name)
f -> [|$expr $(varE $ snd f)|]) (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
unique) [(String, Name)]
uniqueFields
      Name -> [ClauseQ] -> Q Dec
funD 'extractUnique [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []]
    Dec
uniqueNum' <- do
      let index :: Maybe Int
index = (THUniqueDef -> Bool) -> [THUniqueDef] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\THUniqueDef
u -> THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
unique String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== THUniqueDef -> String
thUniqueName THUniqueDef
u) ([THUniqueDef] -> Maybe Int) -> [THUniqueDef] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
constr
      let uNum :: Int
uNum = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"mkUniqueKeysIsUniqueInstances: cannot find unique definition for unique key " String -> String -> String
forall a. [a] -> [a] -> [a]
++ THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
unique) Maybe Int
index
      Name -> [ClauseQ] -> Q Dec
funD 'uniqueNum [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB [|uNum|]) []]
    let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''IsUniqueKey) Type
uniqKeyType) [Dec
extractUnique', Dec
uniqueNum']

mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysEmbeddedInstances THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    [THUniqueKeyDef] -> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((THUniqueKeyDef -> Bool) -> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a. (a -> Bool) -> [a] -> [a]
filter THUniqueKeyDef -> Bool
thUniqueKeyMakeEmbedded ([THUniqueKeyDef] -> [THUniqueKeyDef])
-> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]])
-> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
      Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
      let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
      Type -> [THFieldDef] -> [Type] -> Q [Dec]
mkEmbeddedInstance' Type
uniqKeyType (THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique) [Type]
context

mkUniqueKeysPersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPersistFieldInstances THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
  [THUniqueKeyDef] -> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q Dec) -> Q [Dec])
-> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
    Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]

    Dec
persistName' <- Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyDbName THUniqueKeyDef
unique) []]

    Dec
toPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|pureToPersistValue|]) []]

    Dec
fromPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|pureFromPersistValue|]) []]

    Dec
dbType' <- do
      Name
a <- String -> Q Name
newName String
"a"
      Name
proxy <- String -> Q Name
newName String
"p"
      let mkField :: THFieldDef -> ExpQ
mkField THFieldDef
f = do
            let fname :: String
fname = THFieldDef -> String
thDbFieldName THFieldDef
f
                nvar :: ExpQ
nvar = [|undefined :: $(pure $ thFieldType f)|]
                typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
            [|(fname, $typ)|]
      let embedded :: ExpQ
embedded = [|EmbeddedDef False $(listE $ map mkField $ thUniqueKeyFields unique)|]
          e :: ExpQ
e = [|entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a))|]
          body :: ExpQ
body = [|DbEmbedded $embedded (Just (Left ($e, Just $(lift $ thUniqueKeyName unique)), Nothing, Nothing))|]
      Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ
varP Name
a] (ExpQ -> BodyQ
normalB ExpQ
body) []]
    let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
    let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
uniqKeyType) [Dec]
decs

mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPrimitiveOrPurePersistFieldInstances THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    [THUniqueKeyDef] -> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]])
-> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
      Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
      let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
      let conName :: Name
conName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
unique
      Bool
isUniquePrim <- case THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique of
        [THFieldDef
uniq] -> Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
uniq
        [THFieldDef]
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      if Bool
isUniquePrim
        then do
          Name
x <- String -> Q Name
newName String
"x"
          Dec
toPrim' <- do
            Name -> [ClauseQ] -> Q Dec
funD 'toPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
x]] (ExpQ -> BodyQ
normalB [|toPrimitivePersistValue $(varE x)|]) []]
          Dec
fromPrim' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB [|$(conE conName) (fromPrimitivePersistValue $(varE x))|]) []]
          let decs :: [Dec]
decs = [Dec
toPrim', Dec
fromPrim']
          [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            [ Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PrimitivePersistField) Type
uniqKeyType) [Dec]
decs,
              [Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
context Type
uniqKeyType,
              [Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
context Type
uniqKeyType
            ]
        else Type -> Name -> [THFieldDef] -> [Type] -> Q [Dec]
mkPurePersistFieldInstance Type
uniqKeyType Name
conName (THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique) [Type]
context

mkKeyEqShowInstances :: THEntityDef -> Q [Dec]
mkKeyEqShowInstances :: THEntityDef -> Q [Dec]
mkKeyEqShowInstances THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
  let keysInfo :: [(String, Int, TypeQ)]
keysInfo =
        [(String, Int, TypeQ)]
-> (THAutoKeyDef -> [(String, Int, TypeQ)])
-> Maybe THAutoKeyDef
-> [(String, Int, TypeQ)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\THAutoKeyDef
k -> [(THAutoKeyDef -> String
thAutoKeyConstrName THAutoKeyDef
k, Int
1, [t|BackendSpecific|])]) (THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def)
          [(String, Int, TypeQ)]
-> [(String, Int, TypeQ)] -> [(String, Int, TypeQ)]
forall a. [a] -> [a] -> [a]
++ (THUniqueKeyDef -> (String, Int, TypeQ))
-> [THUniqueKeyDef] -> [(String, Int, TypeQ)]
forall a b. (a -> b) -> [a] -> [b]
map (\THUniqueKeyDef
k -> (THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
k, [THFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([THFieldDef] -> Int) -> [THFieldDef] -> Int
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
k, [t|Unique $(conT $ mkName $ thUniqueKeyPhantomName k)|])) (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def)
  let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
  Type
typ <- [t|Key $(pure entity) $(newName "a" >>= varT)|]

  Dec
showsPrec' <-
    let mkClause :: (String, Int, c) -> ClauseQ
mkClause (String
cName, Int
fieldsNum, c
_) = do
          Name
p <- String -> Q Name
newName String
"p"
          [Name]
fields <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
fieldsNum (String -> Q Name
newName String
"x")
          let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
cName) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
fields
              showC :: ExpQ
showC = [|showString $(lift $ cName ++ " ")|]
              showArgs :: ExpQ
showArgs = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
a ExpQ
b -> [|$a . showString " " . $b|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
a -> [|showsPrec 11 $(varE a)|]) [Name]
fields
              body :: ExpQ
body = [|showParen ($(varE p) >= (11 :: Int)) ($showC . $showArgs)|]
          [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
p, PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []
     in Name -> [ClauseQ] -> Q Dec
funD 'showsPrec ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((String, Int, TypeQ) -> ClauseQ)
-> [(String, Int, TypeQ)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int, TypeQ) -> ClauseQ
forall c. (String, Int, c) -> ClauseQ
mkClause [(String, Int, TypeQ)]
keysInfo

  Dec
eq' <-
    let mkClause :: (String, Int, c) -> ClauseQ
mkClause (String
cName, Int
fieldsNum, c
_) = do
          let fields :: Q [Name]
fields = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
fieldsNum (String -> Q Name
newName String
"x")
          ([Name]
fields1, [Name]
fields2) <- ([Name] -> [Name] -> ([Name], [Name]))
-> Q [Name] -> Q [Name] -> Q ([Name], [Name])
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Q [Name]
fields Q [Name]
fields
          let mkPat :: [Name] -> PatQ
mkPat = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
cName) ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP
              body :: ExpQ
body = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
e1 ExpQ
e2 -> [|$e1 && $e2|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name -> Name -> ExpQ) -> [Name] -> [Name] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n1 Name
n2 -> [|$(varE n1) == $(varE n2)|]) [Name]
fields1 [Name]
fields2
          [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [[Name] -> PatQ
mkPat [Name]
fields1, [Name] -> PatQ
mkPat [Name]
fields2] (ExpQ -> BodyQ
normalB ExpQ
body) []
        clauses :: [ClauseQ]
clauses = ((String, Int, TypeQ) -> ClauseQ)
-> [(String, Int, TypeQ)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int, TypeQ) -> ClauseQ
forall c. (String, Int, c) -> ClauseQ
mkClause [(String, Int, TypeQ)]
keysInfo
        noMatch :: [ClauseQ]
noMatch = if [ClauseQ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClauseQ]
clauses Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP, PatQ
wildP] (ExpQ -> BodyQ
normalB [|False|]) []] else []
     in Name -> [ClauseQ] -> Q Dec
funD '(==) ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ [ClauseQ]
clauses [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. [a] -> [a] -> [a]
++ [ClauseQ]
noMatch

  [Dec]
read' <-
    let mkRead :: (String, Int, TypeQ) -> Q Dec
mkRead (String
cName, Int
fieldsNum, TypeQ
u) = do
          let key :: ExpQ
key =
                (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a ExpQ
b -> [|$a <*> $b|]) [|$(conE $ mkName cName) <$> R.step R.readPrec|] ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
                  Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate (Int
fieldsNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [|R.step R.readPrec|]
              body :: ExpQ
body = [|R.parens $ R.prec 10 $ R.expectP (R.Ident $(litE $ StringL cName)) >> $key|]
          Type
keyType <- [t|Key $(pure entity) $u|]
          Dec
readPrec' <- Name -> [ClauseQ] -> Q Dec
funD 'R.readPrec [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
          Dec
readListPrec' <- Name -> [ClauseQ] -> Q Dec
funD 'R.readListPrec [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|R.readListPrecDefault|]) []]
          Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Read) Type
keyType) [Dec
readPrec', Dec
readListPrec']
     in ((String, Int, TypeQ) -> Q Dec)
-> [(String, Int, TypeQ)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, Int, TypeQ) -> Q Dec
mkRead [(String, Int, TypeQ)]
keysInfo

  [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
$
    if [(String, Int, TypeQ)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Int, TypeQ)]
keysInfo
      then []
      else [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
typ) [Dec
eq'], [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) Type
typ) [Dec
showsPrec']] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
read'

mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedInstance THEmbeddedDef
def = do
  let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def
      embedded :: Type
embedded = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEmbeddedDef -> Name
thEmbeddedName THEmbeddedDef
def)) [Type]
types
      context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def)
  Type -> [THFieldDef] -> [Type] -> Q [Dec]
mkEmbeddedInstance' Type
embedded (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def) [Type]
context

mkEmbeddedInstance' :: Type -> [THFieldDef] -> Cxt -> Q [Dec]
mkEmbeddedInstance' :: Type -> [THFieldDef] -> [Type] -> Q [Dec]
mkEmbeddedInstance' Type
dataType [THFieldDef]
fDefs [Type]
context = do
  Dec
selector' <- do
    Name
fParam <- String -> Q Name
newName String
"f"
    let mkField :: THFieldDef -> Con
mkField THFieldDef
field = [TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
fParam) (THFieldDef -> Type
thFieldType THFieldDef
field)] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
field) []
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [] ''Selector [Type
dataType, Name -> Type
VarT Name
fParam] ((THFieldDef -> Con) -> [THFieldDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map THFieldDef -> Con
mkField [THFieldDef]
fDefs) []

  Dec
selectorNum' <- do
    let mkClause :: t -> THFieldDef -> ClauseQ
mkClause t
fNum THFieldDef
field = [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
field) []] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ t -> ExpQ
forall t. Lift t => t -> ExpQ
lift t
fNum) []
        clauses :: [ClauseQ]
clauses = (Int -> THFieldDef -> ClauseQ)
-> [Int] -> [THFieldDef] -> [ClauseQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> THFieldDef -> ClauseQ
forall t. Lift t => t -> THFieldDef -> ClauseQ
mkClause [Int
0 :: Int ..] [THFieldDef]
fDefs
    Name -> [ClauseQ] -> Q Dec
funD 'selectorNum [ClauseQ]
clauses

  let decs :: [Dec]
decs = [Dec
selector', Dec
selectorNum']
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Embedded) Type
dataType) [Dec]
decs]

mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructors THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
  [THConstructorDef] -> (THConstructorDef -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) ((THConstructorDef -> Q Dec) -> Q [Dec])
-> (THConstructorDef -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \THConstructorDef
c -> do
    Name
v <- String -> Q Name
newName String
"v"
    let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> String
thPhantomConstrName THConstructorDef
c
    Type
phantom <- [t|ConstructorMarker $(pure entity)|]
    let constr :: Con
constr = [Name] -> [BangType] -> Type -> Con
GadtC [Name
name] [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Type
phantom)
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
dataD' [] Name
name [Name -> TyVarBndr
plainTV Name
v] [Con
constr] []

mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructorInstances THEntityDef
def = (Int -> THConstructorDef -> Q Dec)
-> [Int] -> [THConstructorDef] -> Q [Dec]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> THConstructorDef -> Q Dec
f [Int
0 ..] (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def)
  where
    f :: Int -> THConstructorDef -> Q Dec
    f :: Int -> THConstructorDef -> Q Dec
f Int
cNum THConstructorDef
c = CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt []) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Constructor) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> String
thPhantomConstrName THConstructorDef
c)) [Q Dec
phantomConstrNum']
      where
        phantomConstrNum' :: Q Dec
phantomConstrNum' = Name -> [ClauseQ] -> Q Dec
funD 'phantomConstrNum [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB [|cNum|]) []]

mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec]
mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec]
mkEntityUniqueKeysPhantoms THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    [THUniqueKeyDef] -> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]])
-> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
u -> do
      Maybe Name
exists <- String -> Q (Maybe Name)
lookupTypeName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
u
      if Maybe Name -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Name
exists
        then do
          Name
v <- String -> Q Name
newName String
"v"
          let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
u
          Type
phantom <- [t|UniqueMarker $(pure entity)|]
          let constr :: Con
constr = [Name] -> [BangType] -> Type -> Con
GadtC [Name
name] [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Type
phantom)
          [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
dataD' [] Name
name [Name -> TyVarBndr
plainTV Name
v] [Con
constr] []]
        else [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkPersistEntityInstance :: THEntityDef -> Q [Dec]
mkPersistEntityInstance :: THEntityDef -> Q [Dec]
mkPersistEntityInstance THEntityDef
def = do
  let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def

  Dec
key' <- do
    Name
uParam <- String -> Q Name
newName String
"u"
    [Con]
autoKey <- case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
      Maybe THAutoKeyDef
Nothing -> [Con] -> Q [Con]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just THAutoKeyDef
k -> do
        Type
keyDescr <- [t|BackendSpecific|]
        [Con] -> Q [Con]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
uParam) Type
keyDescr] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THAutoKeyDef -> String
thAutoKeyConstrName THAutoKeyDef
k) [(Bang
notStrict', Name -> Type
ConT ''PersistValue)]]
    [Con]
uniques <- [THUniqueKeyDef] -> (THUniqueKeyDef -> Q Con) -> Q [Con]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q Con) -> Q [Con])
-> (THUniqueKeyDef -> Q Con) -> Q [Con]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
      Type
uniqType <- [t|Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)|]
      let cDef :: THConstructorDef
cDef = [THConstructorDef] -> THConstructorDef
forall a. [a] -> a
head ([THConstructorDef] -> THConstructorDef)
-> [THConstructorDef] -> THConstructorDef
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
          uniqFieldNames :: [String]
uniqFieldNames = [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts ([Either String String] -> [String])
-> [Either String String] -> [String]
forall a b. (a -> b) -> a -> b
$ THUniqueDef -> [Either String String]
thUniqueFields (THUniqueDef -> [Either String String])
-> THUniqueDef -> [Either String String]
forall a b. (a -> b) -> a -> b
$ String
-> (THUniqueDef -> String)
-> String
-> [THUniqueDef]
-> THUniqueDef
forall x a. (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne String
"unique" THUniqueDef -> String
thUniqueName (THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
unique) ([THUniqueDef] -> THUniqueDef) -> [THUniqueDef] -> THUniqueDef
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
cDef
          uniqFields :: [THFieldDef]
uniqFields = [[THFieldDef]] -> [THFieldDef]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[THFieldDef]] -> [THFieldDef]) -> [[THFieldDef]] -> [THFieldDef]
forall a b. (a -> b) -> a -> b
$ ((String -> [THFieldDef]) -> [String] -> [[THFieldDef]])
-> [String] -> (String -> [THFieldDef]) -> [[THFieldDef]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> [THFieldDef]) -> [String] -> [[THFieldDef]]
forall a b. (a -> b) -> [a] -> [b]
map [String]
uniqFieldNames ((String -> [THFieldDef]) -> [[THFieldDef]])
-> (String -> [THFieldDef]) -> [[THFieldDef]]
forall a b. (a -> b) -> a -> b
$ \String
name -> (THFieldDef -> Bool) -> [THFieldDef] -> [THFieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name) (String -> Bool) -> (THFieldDef -> String) -> THFieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> String
thFieldName) ([THFieldDef] -> [THFieldDef]) -> [THFieldDef] -> [THFieldDef]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cDef
          uniqFields' :: [BangType]
uniqFields' = (THFieldDef -> BangType) -> [THFieldDef] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\THFieldDef
f -> (Bang
notStrict', THFieldDef -> Type
thFieldType THFieldDef
f)) [THFieldDef]
uniqFields
      Con -> Q Con
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Q Con) -> Con -> Q Con
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
uParam) Type
uniqType] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
unique) [BangType]
uniqFields'
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [] ''Key [Type
entity, Name -> Type
VarT Name
uParam] ([Con]
autoKey [Con] -> [Con] -> [Con]
forall a. [a] -> [a] -> [a]
++ [Con]
uniques) []

  Dec
autoKey' <- do
    Type
autoType <- case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
      Maybe THAutoKeyDef
Nothing -> [t|()|]
      Just THAutoKeyDef
_ -> [t|Key $(pure entity) BackendSpecific|]
    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
$ Name -> [Type] -> Type -> Dec
mkTySynInstD ''AutoKey [Type
entity] Type
autoType

  Dec
defaultKey' <- do
    Type
typ <- case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
      Just THAutoKeyDef
k | THAutoKeyDef -> Bool
thAutoKeyIsDef THAutoKeyDef
k -> [t|Key $(pure entity) BackendSpecific|]
      Maybe THAutoKeyDef
_ -> case (THUniqueKeyDef -> Bool) -> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a. (a -> Bool) -> [a] -> [a]
filter THUniqueKeyDef -> Bool
thUniqueKeyIsDef ([THUniqueKeyDef] -> [THUniqueKeyDef])
-> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def of
        [THUniqueKeyDef
unique] -> [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
        [THUniqueKeyDef]
_ -> [t|()|]
    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
$ Name -> [Type] -> Type -> Dec
mkTySynInstD ''DefaultKey [Type
entity] Type
typ

  Dec
isSumType' <- do
    let isSumType :: Type
isSumType =
          Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$
            if [THConstructorDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
              then ''HFalse
              else ''HTrue
    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
$ Name -> [Type] -> Type -> Dec
mkTySynInstD ''IsSumType [Type
entity] Type
isSumType

  Dec
fields' <- do
    Name
cParam <- String -> Q Name
newName String
"c"
    Name
fParam <- String -> Q Name
newName String
"f"
    let mkField :: Name -> THFieldDef -> Con
mkField Name
name THFieldDef
field = [TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
cParam) (Name -> Type
ConT Name
name), Type -> Type -> Type
equalP' (Name -> Type
VarT Name
fParam) (THFieldDef -> Type
thFieldType THFieldDef
field)] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
field) []
    let f :: THConstructorDef -> [Con]
f THConstructorDef
cdef = (THFieldDef -> Con) -> [THFieldDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> THFieldDef -> Con
mkField (Name -> THFieldDef -> Con) -> Name -> THFieldDef -> Con
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> String
thPhantomConstrName THConstructorDef
cdef) ([THFieldDef] -> [Con]) -> [THFieldDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cdef
    let constrs :: [Con]
constrs = (THConstructorDef -> [Con]) -> [THConstructorDef] -> [Con]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap THConstructorDef -> [Con]
f ([THConstructorDef] -> [Con]) -> [THConstructorDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [] ''Field [Type
entity, Name -> Type
VarT Name
cParam, Name -> Type
VarT Name
fParam] [Con]
constrs []

  Dec
entityDef' <- do
    Name
v <- String -> Q Name
newName String
"v"
    Name
proxy <- String -> Q Name
newName String
"p"
    let mkLambda :: Type -> ExpQ
mkLambda Type
t = [|undefined :: $(pure entity) -> $(pure t)|]
        types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
        typeParams' :: ExpQ
typeParams' = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|dbType $(varE proxy) ($(mkLambda t) $(varE v))|]) [Type]
types
        mkField :: THConstructorDef -> Int -> THFieldDef -> ExpQ
mkField THConstructorDef
c Int
fNum THFieldDef
f = do
          Name
a <- String -> Q Name
newName String
"a"
          let fname :: String
fname = THFieldDef -> String
thDbFieldName THFieldDef
f
              nvar :: ExpQ
nvar =
                if Type -> Bool
hasFreeVars (THFieldDef -> Type
thFieldType THFieldDef
f)
                  then
                    let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
c) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
fNum PatQ
wildP [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [Name -> PatQ
varP Name
a] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate ([THFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) PatQ
wildP
                        wildClause :: [MatchQ]
wildClause = if [THConstructorDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB [|undefined|]) []] else []
                     in ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
v) (PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
a) [] MatchQ -> [MatchQ] -> [MatchQ]
forall a. a -> [a] -> [a]
: [MatchQ]
wildClause)
                  else [|undefined :: $(pure $ thFieldType f)|]
              typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
          [|(fname, $typ)|]
        constrs :: ExpQ
constrs = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (THConstructorDef -> ExpQ) -> [THConstructorDef] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map THConstructorDef -> ExpQ
mkConstructorDef ([THConstructorDef] -> [ExpQ]) -> [THConstructorDef] -> [ExpQ]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
        mkConstructorDef :: THConstructorDef -> ExpQ
mkConstructorDef c :: THConstructorDef
c@(THConstructorDef Name
_ String
_ String
name Maybe String
keyName [THFieldDef]
params [THUniqueDef]
conss) = [|ConstructorDef name keyName $(listE $ map snd fields) $(listE $ map mkConstraint conss)|]
          where
            fields :: [(String, ExpQ)]
fields = (Int -> THFieldDef -> (String, ExpQ))
-> [Int] -> [THFieldDef] -> [(String, ExpQ)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i THFieldDef
f -> (THFieldDef -> String
thFieldName THFieldDef
f, THConstructorDef -> Int -> THFieldDef -> ExpQ
mkField THConstructorDef
c Int
i THFieldDef
f)) [Int
0 ..] [THFieldDef]
params
            mkConstraint :: THUniqueDef -> ExpQ
mkConstraint (THUniqueDef String
uName UniqueType
uType [Either String String]
uFields) = [|UniqueDef (Just uName) uType $(listE $ map getField uFields)|]
            getField :: Either String t -> ExpQ
getField (Left String
fName) = [|Left $(snd $ findOne "field" fst fName fields)|]
            getField (Right t
expr) = [|Right expr|]

        paramNames :: ExpQ
paramNames = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
xs -> [|$p ++ [delim] ++ $xs|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|persistName ($(mkLambda t) $(varE v))|]) [Type]
types
        fullEntityName :: ExpQ
fullEntityName =
          if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types
            then [|$(stringE $ thDbEntityName def)|]
            else [|$(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames)|]

        body :: BodyQ
body = ExpQ -> BodyQ
normalB [|EntityDef $fullEntityName $(lift $ thEntitySchema def) $typeParams' $constrs|]
        entityPat :: PatQ
entityPat = if [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr] -> Bool) -> [TyVarBndr] -> Bool
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def then PatQ
wildP else Name -> PatQ
varP Name
v
    Name -> [ClauseQ] -> Q Dec
funD 'entityDef [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, PatQ
entityPat] BodyQ
body []]

  Dec
toEntityPersistValues' <- ([Clause] -> Dec) -> Q [Clause] -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> [Clause] -> Dec
FunD 'toEntityPersistValues) (Q [Clause] -> Q Dec) -> Q [Clause] -> Q Dec
forall a b. (a -> b) -> a -> b
$
    [(Int, THConstructorDef)]
-> ((Int, THConstructorDef) -> ClauseQ) -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [THConstructorDef] -> [(Int, THConstructorDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([THConstructorDef] -> [(Int, THConstructorDef)])
-> [THConstructorDef] -> [(Int, THConstructorDef)]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) (((Int, THConstructorDef) -> ClauseQ) -> Q [Clause])
-> ((Int, THConstructorDef) -> ClauseQ) -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ \(Int
cNum, THConstructorDef
c) -> do
      (PatQ
pat, ExpQ
body) <- Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues (THConstructorDef -> Name
thConstrName THConstructorDef
c) (THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
c) (\ExpQ
result -> [|(toPrimitivePersistValue ($(lift cNum) :: Int) :) . $result|])
      [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []

  Dec
fromEntityPersistValues' <- do
    Name
xs <- String -> Q Name
newName String
"xs"
    let failureBody :: BodyQ
failureBody = ExpQ -> BodyQ
normalB [|fail (failMessageNamed $(stringE $ show $ thDataName def) $(varE xs))|]
    Name
failureName <- String -> Q Name
newName String
"failure"
    let failure :: MatchQ
failure = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
failureName) []
    [MatchQ]
matches <- [(Integer, THConstructorDef)]
-> ((Integer, THConstructorDef) -> Q MatchQ) -> Q [MatchQ]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Integer] -> [THConstructorDef] -> [(Integer, THConstructorDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def)) (((Integer, THConstructorDef) -> Q MatchQ) -> Q [MatchQ])
-> ((Integer, THConstructorDef) -> Q MatchQ) -> Q [MatchQ]
forall a b. (a -> b) -> a -> b
$ \(Integer
cNum, THConstructorDef
c) -> do
      let cNum' :: PatQ
cNum' = Name -> [PatQ] -> PatQ
conP 'PersistInt64 [Lit -> PatQ
litP (Lit -> PatQ) -> Lit -> PatQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
cNum]
      Name
xs' <- String -> Q Name
newName String
"xs"
      (Bool
_, Exp
body) <- Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues Name
failureName Name
xs' (THConstructorDef -> Name
thConstrName THConstructorDef
c) (THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
c)
      MatchQ -> Q MatchQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MatchQ -> Q MatchQ) -> MatchQ -> Q MatchQ
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> Name -> PatQ -> PatQ
infixP PatQ
cNum' '(:) (Name -> PatQ
varP Name
xs')) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
body) []
    let start :: ExpQ
start = ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) ([MatchQ] -> ExpQ) -> [MatchQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [MatchQ]
matches [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ
failure]
    let failureFunc :: Q Dec
failureFunc = Name -> [ClauseQ] -> Q Dec
funD Name
failureName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
failureBody []]
    Name -> [ClauseQ] -> Q Dec
funD 'fromEntityPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
xs] (ExpQ -> BodyQ
normalB ExpQ
start) [Q Dec
failureFunc]]

  Dec
getUniques' <-
    let hasConstraints :: THConstructorDef -> Bool
hasConstraints = Bool -> Bool
not (Bool -> Bool)
-> (THConstructorDef -> Bool) -> THConstructorDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [THUniqueDef] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([THUniqueDef] -> Bool)
-> (THConstructorDef -> [THUniqueDef]) -> THConstructorDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THConstructorDef -> [THUniqueDef]
thConstrUniques
        clauses :: [ClauseQ]
clauses = (Int -> THConstructorDef -> ClauseQ)
-> [Int] -> [THConstructorDef] -> [ClauseQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> THConstructorDef -> ClauseQ
forall t. Lift t => t -> THConstructorDef -> ClauseQ
mkClause [Int
0 :: Int ..] (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def)
        mkClause :: t -> THConstructorDef -> ClauseQ
mkClause t
cNum THConstructorDef
cdef | Bool -> Bool
not (THConstructorDef -> Bool
hasConstraints THConstructorDef
cdef) = [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
cdef) [PatQ]
pats] (ExpQ -> BodyQ
normalB [|(cNum, [])|]) []
          where
            pats :: [PatQ]
pats = (THFieldDef -> PatQ) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (PatQ -> THFieldDef -> PatQ
forall a b. a -> b -> a
const PatQ
wildP) ([THFieldDef] -> [PatQ]) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cdef
        mkClause t
cNum THConstructorDef
cdef = do
          let allConstrainedFields :: [String]
allConstrainedFields = [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts ([Either String String] -> [String])
-> [Either String String] -> [String]
forall a b. (a -> b) -> a -> b
$ (THUniqueDef -> [Either String String])
-> [THUniqueDef] -> [Either String String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap THUniqueDef -> [Either String String]
thUniqueFields ([THUniqueDef] -> [Either String String])
-> [THUniqueDef] -> [Either String String]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
cdef
          [Maybe (Name, THFieldDef)]
vars <- (THFieldDef -> Q (Maybe (Name, THFieldDef)))
-> [THFieldDef] -> Q [Maybe (Name, THFieldDef)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\THFieldDef
f -> String -> Q Name
newName String
"x" Q Name
-> (Name -> Q (Maybe (Name, THFieldDef)))
-> Q (Maybe (Name, THFieldDef))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> Maybe (Name, THFieldDef) -> Q (Maybe (Name, THFieldDef))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, THFieldDef) -> Q (Maybe (Name, THFieldDef)))
-> Maybe (Name, THFieldDef) -> Q (Maybe (Name, THFieldDef))
forall a b. (a -> b) -> a -> b
$ if THFieldDef -> String
thFieldName THFieldDef
f String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
allConstrainedFields then (Name, THFieldDef) -> Maybe (Name, THFieldDef)
forall a. a -> Maybe a
Just (Name
x, THFieldDef
f) else Maybe (Name, THFieldDef)
forall a. Maybe a
Nothing) ([THFieldDef] -> Q [Maybe (Name, THFieldDef)])
-> [THFieldDef] -> Q [Maybe (Name, THFieldDef)]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cdef
          let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
cdef) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Maybe (Name, THFieldDef) -> PatQ)
-> [Maybe (Name, THFieldDef)] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (PatQ
-> ((Name, THFieldDef) -> PatQ) -> Maybe (Name, THFieldDef) -> PatQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PatQ
wildP (Name -> PatQ
varP (Name -> PatQ)
-> ((Name, THFieldDef) -> Name) -> (Name, THFieldDef) -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> Name
forall a b. (a, b) -> a
fst)) [Maybe (Name, THFieldDef)]
vars
              body :: BodyQ
body = ExpQ -> BodyQ
normalB [|(cNum, $(listE $ mapMaybe mkUnique $ thConstrUniques cdef))|]
              mkUnique :: THUniqueDef -> Maybe ExpQ
mkUnique (THUniqueDef String
uName UniqueType
_ [Either String String]
fnames) =
                if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [Either String String] -> [String]
forall a b. [Either a b] -> [b]
rights [Either String String]
fnames
                  then
                    let -- find corresponding field from vars
                        uFields :: [(Name, THFieldDef)]
uFields = (String -> (Name, THFieldDef)) -> [String] -> [(Name, THFieldDef)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
f -> String
-> ((Name, THFieldDef) -> String)
-> String
-> [(Name, THFieldDef)]
-> (Name, THFieldDef)
forall x a. (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne String
"field" (THFieldDef -> String
thFieldName (THFieldDef -> String)
-> ((Name, THFieldDef) -> THFieldDef)
-> (Name, THFieldDef)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) String
f ([(Name, THFieldDef)] -> (Name, THFieldDef))
-> [(Name, THFieldDef)] -> (Name, THFieldDef)
forall a b. (a -> b) -> a -> b
$ [Maybe (Name, THFieldDef)] -> [(Name, THFieldDef)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Name, THFieldDef)]
vars) ([String] -> [(Name, THFieldDef)])
-> [String] -> [(Name, THFieldDef)]
forall a b. (a -> b) -> a -> b
$ [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String String]
fnames
                        result :: ExpQ
result = [(Name, THFieldDef)] -> ExpQ
mkToPurePersistValues [(Name, THFieldDef)]
uFields
                     in ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just [|(uName, $result)|]
                  else Maybe ExpQ
forall a. Maybe a
Nothing
          [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] BodyQ
body []
     in Name -> [ClauseQ] -> Q Dec
funD 'getUniques [ClauseQ]
clauses

  Dec
entityFieldChain' <-
    let thFieldNames :: [THFieldDef]
thFieldNames = THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields
        clauses :: [ClauseQ]
clauses = (THFieldDef -> ClauseQ) -> [THFieldDef] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map THFieldDef -> ClauseQ
mkClause [THFieldDef]
thFieldNames
        mkClause :: THFieldDef -> ClauseQ
mkClause THFieldDef
f = do
          Name
fArg <- String -> Q Name
newName String
"f"
          Name
proxy <- String -> Q Name
newName String
"p"
          let nvar :: ExpQ
nvar = [|(undefined :: Field v c a -> a) $(varE fArg)|]
              typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
              body :: ExpQ
body = [|(($(lift $ thDbFieldName f), $typ), [])|]
          [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ -> PatQ
asP Name
fArg (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> [PatQ] -> PatQ
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
f) []] (ExpQ -> BodyQ
normalB ExpQ
body) []
        clauses' :: [ClauseQ]
clauses' = if [ClauseQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClauseQ]
clauses then [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB [|undefined|]) []] else [ClauseQ]
clauses
     in Name -> [ClauseQ] -> Q Dec
funD 'entityFieldChain [ClauseQ]
clauses'

  let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
  let decs :: [Dec]
decs = [Dec
key', Dec
autoKey', Dec
defaultKey', Dec
isSumType', Dec
fields', Dec
entityDef', Dec
toEntityPersistValues', Dec
fromEntityPersistValues', Dec
getUniques', Dec
entityFieldChain']
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistEntity) Type
entity) [Dec]
decs]

mkToPurePersistValues :: [(Name, THFieldDef)] -> Q Exp
mkToPurePersistValues :: [(Name, THFieldDef)] -> ExpQ
mkToPurePersistValues [(Name, THFieldDef)]
vars = do
  let processField :: (Name, THFieldDef) -> Q (Maybe (Q Dec), ExpQ)
processField (Name
fName, THFieldDef
fDef) = do
        Bool
isP <- Type -> Q Bool
isPrim (THFieldDef -> Type
thFieldType THFieldDef
fDef)
        let field :: ExpQ
field = (ExpQ -> ExpQ)
-> (Name -> ExpQ -> ExpQ) -> Maybe Name -> ExpQ -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ -> ExpQ
forall a. a -> a
id (\Name
convName ExpQ
x -> [|fst $(varE convName) $ $x|]) (THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef) (Name -> ExpQ
varE Name
fName)
        if Bool
isP
          then (Maybe (Q Dec), ExpQ) -> Q (Maybe (Q Dec), ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Q Dec)
forall a. Maybe a
Nothing, [|(toPrimitivePersistValue $field :)|])
          else String -> Q Name
newName String
"x" Q Name
-> (Name -> Q (Maybe (Q Dec), ExpQ)) -> Q (Maybe (Q Dec), ExpQ)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> (Maybe (Q Dec), ExpQ) -> Q (Maybe (Q Dec), ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Dec -> Maybe (Q Dec)
forall a. a -> Maybe a
Just (Q Dec -> Maybe (Q Dec)) -> Q Dec -> Maybe (Q Dec)
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
x) (ExpQ -> BodyQ
normalB [|toPurePersistValues $(varE fName)|]) [], Name -> ExpQ
varE Name
x)
  ([Q Dec]
lets, [ExpQ]
funcs) <- ([(Maybe (Q Dec), ExpQ)] -> ([Q Dec], [ExpQ]))
-> Q [(Maybe (Q Dec), ExpQ)] -> Q ([Q Dec], [ExpQ])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Maybe (Q Dec)] -> [Q Dec])
-> ([Maybe (Q Dec)], [ExpQ]) -> ([Q Dec], [ExpQ])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Maybe (Q Dec)] -> [Q Dec]
forall a. [Maybe a] -> [a]
catMaybes (([Maybe (Q Dec)], [ExpQ]) -> ([Q Dec], [ExpQ]))
-> ([(Maybe (Q Dec), ExpQ)] -> ([Maybe (Q Dec)], [ExpQ]))
-> [(Maybe (Q Dec), ExpQ)]
-> ([Q Dec], [ExpQ])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Maybe (Q Dec), ExpQ)] -> ([Maybe (Q Dec)], [ExpQ])
forall a b. [(a, b)] -> ([a], [b])
unzip) (Q [(Maybe (Q Dec), ExpQ)] -> Q ([Q Dec], [ExpQ]))
-> Q [(Maybe (Q Dec), ExpQ)] -> Q ([Q Dec], [ExpQ])
forall a b. (a -> b) -> a -> b
$ ((Name, THFieldDef) -> Q (Maybe (Q Dec), ExpQ))
-> [(Name, THFieldDef)] -> Q [(Maybe (Q Dec), ExpQ)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, THFieldDef) -> Q (Maybe (Q Dec), ExpQ)
processField [(Name, THFieldDef)]
vars
  let result :: ExpQ
result = if [ExpQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExpQ]
funcs then [|id|] else (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
a ExpQ
b -> [|$a . $b|]) [ExpQ]
funcs
  if [Q Dec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Q Dec]
lets then ExpQ
result else [Q Dec] -> ExpQ -> ExpQ
letE [Q Dec]
lets ExpQ
result

mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntityPersistFieldInstance THEntityDef
def = case THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def of
  Just Either THAutoKeyDef THUniqueKeyDef
defaultKey -> do
    let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
    let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) [Type]
types

    Dec
persistName' <- do
      Name
v <- String -> Q Name
newName String
"v"
      let mkLambda :: Type -> ExpQ
mkLambda Type
t = [|undefined :: $(pure entity) -> $(pure t)|]

      let paramNames :: ExpQ
paramNames = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
xs -> [|$p ++ [delim] ++ $xs|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|persistName ($(mkLambda t) $(varE v))|]) [Type]
types
      let fullEntityName :: ExpQ
fullEntityName = case [Type]
types of
            [] -> [|$(stringE $ thDbEntityName def)|]
            [Type]
_ -> [|$(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames)|]
      let body :: BodyQ
body = ExpQ -> BodyQ
normalB ExpQ
fullEntityName
      let pat :: PatQ
pat = if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types then PatQ
wildP else Name -> PatQ
varP Name
v
      Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] BodyQ
body []]

    Bool
isOne <- THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def
    let mUniqName :: Maybe Name
mUniqName = (THAutoKeyDef -> Maybe Name)
-> (THUniqueKeyDef -> Maybe Name)
-> Either THAutoKeyDef THUniqueKeyDef
-> Maybe Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either THAutoKeyDef -> Maybe Name
forall p a. p -> Maybe a
auto THUniqueKeyDef -> Maybe Name
uniq Either THAutoKeyDef THUniqueKeyDef
defaultKey
          where
            auto :: p -> Maybe a
auto p
_ = Maybe a
forall a. Maybe a
Nothing
            uniq :: THUniqueKeyDef -> Maybe Name
uniq THUniqueKeyDef
u = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
u

    Dec
toPersistValues' <- do
      let body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ case Maybe Name
mUniqName of
            Maybe Name
_ | Bool
isOne -> [|singleToPersistValue|]
            Just Name
name -> [|toPersistValuesUnique $(conE name)|]
            Maybe Name
_ -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"mkEntityPersistFieldInstance: key has no unique type"
      Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
body []]

    Dec
fromPersistValues' <- do
      let body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ case Maybe Name
mUniqName of
            Maybe Name
_ | Bool
isOne -> [|singleFromPersistValue|]
            Just Name
name -> [|fromPersistValuesUnique $(conE name)|]
            Maybe Name
_ -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"mkEntityPersistFieldInstance: key has no unique type"
      Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
body []]

    Dec
dbType' <- do
      Name
proxy <- String -> Q Name
newName String
"p"
      let body :: ExpQ
body = [|dbType $(varE proxy) . (undefined :: a -> DefaultKey a)|]
      Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy] (ExpQ -> BodyQ
normalB ExpQ
body) []]

    let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
    let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
entity) [Dec]
decs]
  Maybe (Either THAutoKeyDef THUniqueKeyDef)
Nothing -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntitySinglePersistFieldInstance THEntityDef
def =
  THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def Q Bool -> (Bool -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
isOne -> case THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def of
    Just Either THAutoKeyDef THUniqueKeyDef
defaultKey | Bool
isOne -> do
      let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
          entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) [Type]
types
          context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)

          (ExpQ
to, ExpQ
from) = case Either THAutoKeyDef THUniqueKeyDef
defaultKey of
            Left THAutoKeyDef
_ -> ([|toSinglePersistValueAutoKey|], [|fromSinglePersistValueAutoKey|])
            Right THUniqueKeyDef
k -> ([|toSinglePersistValueUnique $u|], [|fromSinglePersistValueUnique $u|])
              where
                u :: ExpQ
u = Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
k

      Dec
toSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'toSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
to) []]
      Dec
fromSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'fromSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
from) []]
      let decs :: [Dec]
decs = [Dec
toSinglePersistValue', Dec
fromSinglePersistValue']
      [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''SinglePersistField) Type
entity) [Dec]
decs]
    Maybe (Either THAutoKeyDef THUniqueKeyDef)
_ -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkEntityNeverNullInstance :: THEntityDef -> Q [Dec]
mkEntityNeverNullInstance :: THEntityDef -> Q [Dec]
mkEntityNeverNullInstance THEntityDef
def = do
  let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
      entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) [Type]
types
      context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
  Bool
isOne <- THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def
  [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
$
    if Bool
isOne
      then [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''NeverNull) Type
entity) []]
      else []

mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePersistFieldInstance THPrimitiveDef
def = do
  let primitive :: Type
primitive = Name -> Type
ConT (THPrimitiveDef -> Name
thPrimitiveName THPrimitiveDef
def)
  Dec
persistName' <- do
    let body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ THPrimitiveDef -> Name
thPrimitiveName THPrimitiveDef
def
    Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] BodyQ
body []]
  Dec
fromPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromPersistValue|]) []]
  Dec
toPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToPersistValue|]) []]
  Dec
dbType' <- do
    Name
proxy <- String -> Q Name
newName String
"p"
    Name
x <- String -> Q Name
newName String
"x"
    let body :: ExpQ
body = [|dbType $(varE proxy) $ fst $(varE $ thPrimitiveConverter def) $(varE x)|]
    Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB ExpQ
body) []]
  let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ [Type] -> Type -> [Dec] -> Dec
instanceD' [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
primitive) [Dec]
decs,
      [Type] -> Type -> [Dec] -> Dec
instanceD' [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''NeverNull) Type
primitive) []
    ]

mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePrimitivePersistFieldInstance THPrimitiveDef
def = do
  let primitive :: Type
primitive = Name -> Type
ConT (THPrimitiveDef -> Name
thPrimitiveName THPrimitiveDef
def)
  Dec
toPrim' <- do
    let body :: ExpQ
body = [|toPrimitivePersistValue . fst $(varE $ thPrimitiveConverter def)|]
    Name -> [ClauseQ] -> Q Dec
funD 'toPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
  Dec
fromPrim' <- do
    let body :: ExpQ
body = [|snd $(varE $ thPrimitiveConverter def) . fromPrimitivePersistValue|]
    Name -> [ClauseQ] -> Q Dec
funD 'fromPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
  let context :: [a]
context = []
  let decs :: [Dec]
decs = [Dec
toPrim', Dec
fromPrim']
  [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
forall a. [a]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PrimitivePersistField) Type
primitive) [Dec]
decs,
      [Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
forall a. [a]
context Type
primitive,
      [Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
forall a. [a]
context Type
primitive
    ]

mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec]
mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec]
mkMigrateFunction String
name [THEntityDef]
defs = do
  let ([THEntityDef]
normal, [THEntityDef]
polymorhpic) = (THEntityDef -> Bool)
-> [THEntityDef] -> ([THEntityDef], [THEntityDef])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr] -> Bool)
-> (THEntityDef -> [TyVarBndr]) -> THEntityDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THEntityDef -> [TyVarBndr]
thTypeParams) [THEntityDef]
defs
  [THEntityDef] -> (THEntityDef -> Q ()) -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [THEntityDef]
polymorhpic ((THEntityDef -> Q ()) -> Q ()) -> (THEntityDef -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \THEntityDef
def -> String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Datatype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (THEntityDef -> Name
thDataName THEntityDef
def) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" will not be migrated automatically by function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" because it has type parameters"
  let body :: ExpQ
body = [StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (THEntityDef -> StmtQ) -> [THEntityDef] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map (\THEntityDef
def -> ExpQ -> StmtQ
noBindS [|migrate (undefined :: $(conT $ thDataName def))|]) [THEntityDef]
normal
  Dec
sig <- Name -> TypeQ -> Q Dec
sigD (String -> Name
mkName String
name) [t|forall m. PersistBackend m => Migration m|]
  Dec
func <- Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName String
name) [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sig, Dec
func]

isDefaultKeyOneColumn :: THEntityDef -> Q Bool
isDefaultKeyOneColumn :: THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def = case THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def of
  Just (Left THAutoKeyDef
_) -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Just (Right THUniqueKeyDef
unique) -> case THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique of
    [THFieldDef
field] -> Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
field
    [THFieldDef]
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Maybe (Either THAutoKeyDef THUniqueKeyDef)
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

getDefaultKey :: THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey :: THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def = case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
  Just THAutoKeyDef
k | THAutoKeyDef -> Bool
thAutoKeyIsDef THAutoKeyDef
k -> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a. a -> Maybe a
Just (Either THAutoKeyDef THUniqueKeyDef
 -> Maybe (Either THAutoKeyDef THUniqueKeyDef))
-> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a b. (a -> b) -> a -> b
$ THAutoKeyDef -> Either THAutoKeyDef THUniqueKeyDef
forall a b. a -> Either a b
Left THAutoKeyDef
k
  Maybe THAutoKeyDef
_ -> case (THUniqueKeyDef -> Bool) -> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a. (a -> Bool) -> [a] -> [a]
filter THUniqueKeyDef -> Bool
thUniqueKeyIsDef ([THUniqueKeyDef] -> [THUniqueKeyDef])
-> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def of
    [] -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a. Maybe a
Nothing
    (THUniqueKeyDef
u : [THUniqueKeyDef]
_) -> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a. a -> Maybe a
Just (Either THAutoKeyDef THUniqueKeyDef
 -> Maybe (Either THAutoKeyDef THUniqueKeyDef))
-> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> Either THAutoKeyDef THUniqueKeyDef
forall a b. b -> Either a b
Right THUniqueKeyDef
u

#if MIN_VERSION_template_haskell(2, 17, 0)
paramsContext :: [TH.TyVarBndr flag] -> [THFieldDef] -> Cxt
#else
paramsContext :: [TyVarBndr] -> [THFieldDef] -> Cxt
#endif
paramsContext :: [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext [TyVarBndr]
types [THFieldDef]
fields = Name -> [Type] -> [Type]
classPred ''PersistField [Type]
params [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''SinglePersistField [Type]
maybys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''NeverNull [Type]
maybys
  where
    classPred :: Name -> [Type] -> [Type]
classPred Name
clazz = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> Name -> [Type] -> Type
classP' Name
clazz [Type
t])
    -- every type must be an instance of PersistField
    params :: [Type]
params = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType [TyVarBndr]
types
    -- all datatype fields also must be instances of PersistField
    -- if Maybe is applied to a type param, the param must be also an instance of NeverNull
    -- so that (Maybe param) is an instance of PersistField
    maybys :: [Type]
maybys = [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [THFieldDef]
fields [THFieldDef] -> (THFieldDef -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> [Type]
insideMaybe (Type -> [Type]) -> (THFieldDef -> Type) -> THFieldDef -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType

#if MIN_VERSION_template_haskell(2, 17, 0)
paramsPureContext :: [TH.TyVarBndr flag] -> [THFieldDef] -> Q (Maybe Cxt)
#else
paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe Cxt)
#endif
paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe [Type])
paramsPureContext [TyVarBndr]
types [THFieldDef]
fields = do
  let isValidType :: Type -> Q Bool
isValidType (VarT Name
_) = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      isValidType Type
t = Type -> Q Bool
isPrim Type
t
  [THFieldDef]
invalid <- (THFieldDef -> Q Bool) -> [THFieldDef] -> Q [THFieldDef]
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 (Q Bool -> Q Bool)
-> (THFieldDef -> Q Bool) -> THFieldDef -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Bool
isValidType (Type -> Q Bool) -> (THFieldDef -> Type) -> THFieldDef -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType) [THFieldDef]
fields
  Maybe [Type] -> Q (Maybe [Type])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Type] -> Q (Maybe [Type]))
-> Maybe [Type] -> Q (Maybe [Type])
forall a b. (a -> b) -> a -> b
$ case [THFieldDef]
invalid of
    [] -> [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just ([Type] -> Maybe [Type]) -> [Type] -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> [Type]
classPred ''PurePersistField [Type]
params [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''PrimitivePersistField [Type]
maybys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''NeverNull [Type]
maybys
      where
        params :: [Type]
params = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType [TyVarBndr]
types
        classPred :: Name -> [Type] -> [Type]
classPred Name
clazz = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> Name -> [Type] -> Type
classP' Name
clazz [Type
t])
        -- all datatype fields also must be instances of PersistField
        -- if Maybe is applied to a type param, the param must be also an instance of NeverNull
        -- so that (Maybe param) is an instance of PersistField
        maybys :: [Type]
maybys = [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [THFieldDef]
fields [THFieldDef] -> (THFieldDef -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> [Type]
insideMaybe (Type -> [Type]) -> (THFieldDef -> Type) -> THFieldDef -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType
    [THFieldDef]
_ -> Maybe [Type]
forall a. Maybe a
Nothing

#if MIN_VERSION_template_haskell(2, 17, 0)
extractType :: TH.TyVarBndr flag -> Type
extractType (PlainTV name _) = VarT name
extractType (KindedTV name _ _) = VarT name
#else
extractType :: TyVarBndr -> Type
extractType :: TyVarBndr -> Type
extractType (PlainTV Name
name) = Name -> Type
VarT Name
name
extractType (KindedTV Name
name Type
_) = Name -> Type
VarT Name
name
#endif

#if MIN_VERSION_template_haskell(2, 7, 0)
#define isClassInstance isInstance
#endif

#if !MIN_VERSION_template_haskell(2, 8, 0)
reportWarning :: String -> Q ()
reportWarning = report False
#endif

isPrim :: Type -> Q Bool
-- we cannot use simply isClassInstance because it crashes on type vars and in this case
-- class PrimitivePersistField a
-- instance PrimitivePersistField Int
-- instance PrimitivePersistField a => Maybe a
-- it will consider (Maybe anytype) instance of PrimitivePersistField
isPrim :: Type -> Q Bool
isPrim Type
t | Type -> Bool
hasFreeVars Type
t = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isPrim t :: Type
t@(ConT Name
_) = isClassInstance ''PrimitivePersistField [t]
--isPrim (AppT (ConT key) _)  | key == ''Key = return True
isPrim (AppT (AppT (ConT Name
key) Type
_) (AppT (AppT Type
_ (ConT Name
typ)) Type
_)) | Name
key Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Key Bool -> Bool -> Bool
&& Name
typ Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''BackendSpecific = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
isPrim (AppT (ConT Name
tcon) Type
t) | Name
tcon Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = Type -> Q Bool
isPrim Type
t
isPrim Type
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a
foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a
foldType Type -> a
f a -> a -> a
app = Type -> a
go
  where
    go :: Type -> a
go ForallT {} = String -> a
forall a. HasCallStack => String -> a
error String
"forall'ed fields are not allowed"
    go z :: Type
z@(AppT Type
a Type
b) = Type -> a
f Type
z a -> a -> a
`app` Type -> a
go Type
a a -> a -> a
`app` Type -> a
go Type
b
    go z :: Type
z@(SigT Type
t Type
_) = Type -> a
f Type
z a -> a -> a
`app` Type -> a
go Type
t
    go Type
z = Type -> a
f Type
z

hasFreeVars :: Type -> Bool
hasFreeVars :: Type -> Bool
hasFreeVars = (Type -> Bool) -> (Bool -> Bool -> Bool) -> Type -> Bool
forall a. (Type -> a) -> (a -> a -> a) -> Type -> a
foldType Type -> Bool
f Bool -> Bool -> Bool
(||)
  where
    f :: Type -> Bool
f (VarT Name
_) = Bool
True
    f Type
_ = Bool
False

insideMaybe :: Type -> [Type]
insideMaybe :: Type -> [Type]
insideMaybe = (Type -> [Type]) -> ([Type] -> [Type] -> [Type]) -> Type -> [Type]
forall a. (Type -> a) -> (a -> a -> a) -> Type -> a
foldType Type -> [Type]
f [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
(++)
  where
    f :: Type -> [Type]
f (AppT (ConT Name
c) t :: Type
t@(VarT Name
_)) | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = [Type
t]
    f Type
_ = []

spanM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
spanM :: (a -> m Bool) -> [a] -> m ([a], [a])
spanM a -> m Bool
p = [a] -> m ([a], [a])
go
  where
    go :: [a] -> m ([a], [a])
go [] = ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
    go (a
x : [a]
xs) = do
      Bool
flg <- a -> m Bool
p a
x
      if Bool
flg
        then do
          ([a]
ys, [a]
zs) <- [a] -> m ([a], [a])
go [a]
xs
          ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys, [a]
zs)
        else ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)

mkType :: THFieldDef -> Name -> ExpQ -> ExpQ
mkType :: THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef {String
Maybe String
Maybe [PSFieldDef String]
Maybe Name
Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
Type
thReferenceParent :: THFieldDef
-> Maybe
     (Maybe ((Maybe String, String), [String]),
      Maybe ReferenceActionType, Maybe ReferenceActionType)
thDefaultValue :: THFieldDef -> Maybe String
thEmbeddedDef :: THFieldDef -> Maybe [PSFieldDef String]
thDbTypeName :: THFieldDef -> Maybe String
thFieldConverter :: Maybe Name
thReferenceParent :: Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
thDefaultValue :: Maybe String
thEmbeddedDef :: Maybe [PSFieldDef String]
thFieldType :: Type
thExprName :: String
thDbTypeName :: Maybe String
thDbFieldName :: String
thFieldName :: String
thExprName :: THFieldDef -> String
thFieldName :: THFieldDef -> String
thFieldConverter :: THFieldDef -> Maybe Name
thFieldType :: THFieldDef -> Type
thDbFieldName :: THFieldDef -> String
..} Name
proxy ExpQ
nvar = ExpQ
t3
  where
    psField :: PSFieldDef String
psField = String
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe [PSFieldDef String]
-> Maybe String
-> Maybe
     (Maybe ((Maybe String, String), [String]),
      Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe String
-> PSFieldDef String
forall str.
str
-> Maybe str
-> Maybe str
-> Maybe str
-> Maybe [PSFieldDef str]
-> Maybe str
-> Maybe
     (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType,
      Maybe ReferenceActionType)
-> Maybe str
-> PSFieldDef str
PSFieldDef String
thFieldName (String -> Maybe String
forall a. a -> Maybe a
Just String
thDbFieldName) Maybe String
thDbTypeName (String -> Maybe String
forall a. a -> Maybe a
Just String
thExprName) Maybe [PSFieldDef String]
thEmbeddedDef Maybe String
thDefaultValue Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
thReferenceParent ((Name -> String) -> Maybe Name -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> String
forall a. Show a => a -> String
show Maybe Name
thFieldConverter)
    t1 :: ExpQ
t1 = (ExpQ -> ExpQ)
-> (Name -> ExpQ -> ExpQ) -> Maybe Name -> ExpQ -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ -> ExpQ
forall a. a -> a
id (\Name
convName ExpQ
x -> [|fst $(varE convName) $ $x|]) Maybe Name
thFieldConverter ExpQ
nvar
    t2 :: ExpQ
t2 = [|dbType $(varE proxy) $t1|]
    -- if there are any type settings, apply them in runtime
    t3 :: ExpQ
t3 = case (Maybe String
thDbTypeName, Maybe [PSFieldDef String]
thEmbeddedDef, Maybe String
thDefaultValue, Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
thReferenceParent) of
      (Maybe String
Nothing, Maybe [PSFieldDef String]
Nothing, Maybe String
Nothing, Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
Nothing) -> ExpQ
t2
      (Maybe String, Maybe [PSFieldDef String], Maybe String,
 Maybe
   (Maybe ((Maybe String, String), [String]),
    Maybe ReferenceActionType, Maybe ReferenceActionType))
_ -> [|applyDbTypeSettings $(lift psField) $t2|]

mkTySynInstD :: Name -> [Type] -> Type -> Dec
#if MIN_VERSION_template_haskell(2, 15, 0)
mkTySynInstD :: Name -> [Type] -> Type -> Dec
mkTySynInstD Name
name [Type]
ts Type
t =
  TySynEqn -> Dec
TySynInstD (TySynEqn -> Dec) -> TySynEqn -> Dec
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
typ Type
t where
    typ :: Type
typ = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
ts
#elif MIN_VERSION_template_haskell(2, 9, 0)
mkTySynInstD name ts t = TySynInstD name $ TySynEqn ts t
#else
mkTySynInstD = TySynInstD
#endif

classP' :: Name -> [Type] -> Pred
#if MIN_VERSION_template_haskell(2, 10, 0)
classP' :: Name -> [Type] -> Type
classP' Name
name [Type]
ts = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
ts
#else
classP' = ClassP
#endif

equalP' :: Type -> Type -> Pred
#if MIN_VERSION_template_haskell(2, 10, 0)
equalP' :: Type -> Type -> Type
equalP' Type
t1 Type
t2 = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
EqualityT [Type
t1, Type
t2]
#else
equalP'= EqualP
#endif

instanceD' :: Cxt -> Type -> [Dec] -> InstanceDec
#if MIN_VERSION_template_haskell(2, 11, 0)
instanceD' :: [Type] -> Type -> [Dec] -> Dec
instanceD' = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing
#else
instanceD' = InstanceD
#endif

dataInstD' :: Cxt -> Name -> [Type] -> [Con] -> [Name] -> InstanceDec
#if MIN_VERSION_template_haskell(2, 15, 0)
dataInstD' :: [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [Type]
context Name
name [Type]
types [Con]
constrs [Name]
derives =
  [Type]
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [Type]
context Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
typ Maybe Type
forall a. Maybe a
Nothing [Con]
constrs [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
derives)] where
    typ :: Type
typ = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
types
#elif MIN_VERSION_template_haskell(2, 12, 0)
dataInstD' context name types constrs derives =
  DataInstD context name types Nothing constrs [DerivClause Nothing (map ConT derives)]
#elif MIN_VERSION_template_haskell(2, 11, 0)
dataInstD' context name types constrs derives =
  DataInstD context name types Nothing constrs (map ConT derives)
#else
dataInstD' = DataInstD
#endif

dataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> InstanceDec

#if MIN_VERSION_template_haskell(2, 12, 0)
dataD' :: [Type] -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
dataD' [Type]
context Name
name [TyVarBndr]
types [Con]
constrs [Name]
derives =
  [Type]
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [Type]
context Name
name [TyVarBndr]
types Maybe Type
forall a. Maybe a
Nothing [Con]
constrs [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
derives)]
#elif MIN_VERSION_template_haskell(2, 11, 0)
dataD' context name types constrs derives =
  DataD context name types Nothing constrs (map ConT derives)
#else
dataD' = DataD
#endif

#if MIN_VERSION_template_haskell(2, 11, 0)
notStrict' :: Bang
notStrict' :: Bang
notStrict' = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
#else
notStrict' :: Strict
notStrict' = NotStrict
#endif

#if MIN_VERSION_template_haskell(2, 17, 0)
type TyVarBndr = TH.TyVarBndr ()
#else
type TyVarBndr = TH.TyVarBndr
#endif