{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Database.Esqueleto.Record
( deriveEsqueletoRecord
) where
import Control.Monad.Trans.State.Strict (StateT(..), evalStateT)
import Data.Proxy (Proxy(..))
import Database.Esqueleto.Experimental
(Entity, PersistValue, SqlExpr, Value(..), (:&)(..))
import Database.Esqueleto.Internal.Internal (SqlSelect(..))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Bifunctor (first)
import Data.Text (Text)
import Control.Monad (forM)
import Data.Foldable (foldl')
import GHC.Exts (IsString(fromString))
import Data.Maybe (mapMaybe, fromMaybe, listToMaybe)
deriveEsqueletoRecord :: Name -> Q [Dec]
deriveEsqueletoRecord :: Name -> Q [Dec]
deriveEsqueletoRecord Name
originalName = do
RecordInfo
info <- Name -> Q RecordInfo
getRecordInfo Name
originalName
Dec
recordDec <- RecordInfo -> Q Dec
makeSqlRecord RecordInfo
info
Dec
instanceDec <- RecordInfo -> Q Dec
makeSqlSelectInstance RecordInfo
info
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Dec
recordDec
, Dec
instanceDec
]
data RecordInfo = RecordInfo
{
RecordInfo -> Name
name :: Name
,
RecordInfo -> Name
sqlName :: Name
,
RecordInfo -> Cxt
constraints :: Cxt
,
#if MIN_VERSION_template_haskell(2,17,0)
typeVarBinders :: [TyVarBndr ()]
#else
RecordInfo -> [TyVarBndr]
typeVarBinders :: [TyVarBndr]
#endif
,
RecordInfo -> Maybe Kind
kind :: Maybe Kind
,
RecordInfo -> Name
constructorName :: Name
,
RecordInfo -> [(Name, Kind)]
fields :: [(Name, Type)]
,
RecordInfo -> [(Name, Kind)]
sqlFields :: [(Name, Type)]
}
getRecordInfo :: Name -> Q RecordInfo
getRecordInfo :: Name -> Q RecordInfo
getRecordInfo Name
name = do
TyConI Dec
dec <- Name -> Q Info
reify Name
name
(Cxt
constraints, [TyVarBndr]
typeVarBinders, Maybe Kind
kind, [Con]
constructors) <-
case Dec
dec of
DataD Cxt
constraints' Name
_name [TyVarBndr]
typeVarBinders' Maybe Kind
kind' [Con]
constructors' [DerivClause]
_derivingClauses ->
(Cxt, [TyVarBndr], Maybe Kind, [Con])
-> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt
constraints', [TyVarBndr]
typeVarBinders', Maybe Kind
kind', [Con]
constructors')
NewtypeD Cxt
constraints' Name
_name [TyVarBndr]
typeVarBinders' Maybe Kind
kind' Con
constructor' [DerivClause]
_derivingClauses ->
(Cxt, [TyVarBndr], Maybe Kind, [Con])
-> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt
constraints', [TyVarBndr]
typeVarBinders', Maybe Kind
kind', [Con
constructor'])
Dec
_ -> String -> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Cxt, [TyVarBndr], Maybe Kind, [Con]))
-> String -> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall a b. (a -> b) -> a -> b
$ String
"Esqueleto records can only be derived for records and newtypes, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is neither"
Con
constructor <- case [Con]
constructors of
(Con
c : [Con]
_) -> Con -> Q Con
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
c
[] -> String -> Q Con
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Con) -> String -> Q Con
forall a b. (a -> b) -> a -> b
$ String
"Cannot derive Esqueleto record for a type with no constructors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
let constructorName :: Name
constructorName =
case [Con] -> Con
forall a. [a] -> a
head [Con]
constructors of
RecC Name
name' [VarBangType]
_fields -> Name
name'
Con
con -> String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Con -> String
nonRecordConstructorMessage Con
con
fields :: [(Name, Kind)]
fields = Con -> [(Name, Kind)]
getFields Con
constructor
sqlName :: Name
sqlName = Name -> Name
makeSqlName Name
name
[(Name, Kind)]
sqlFields <- ((Name, Kind) -> Q (Name, Kind))
-> [(Name, Kind)] -> Q [(Name, Kind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, Kind) -> Q (Name, Kind)
forall a. (a, Kind) -> Q (a, Kind)
toSqlField [(Name, Kind)]
fields
RecordInfo -> Q RecordInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordInfo :: Name
-> Name
-> Cxt
-> [TyVarBndr]
-> Maybe Kind
-> Name
-> [(Name, Kind)]
-> [(Name, Kind)]
-> RecordInfo
RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
sqlName :: Name
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
name :: Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
..}
where
getFields :: Con -> [(Name, Type)]
getFields :: Con -> [(Name, Kind)]
getFields (RecC Name
_name [VarBangType]
fields) = [(Name
fieldName', Kind
fieldType') | (Name
fieldName', Bang
_bang, Kind
fieldType') <- [VarBangType]
fields]
getFields Con
con = String -> [(Name, Kind)]
forall a. HasCallStack => String -> a
error (String -> [(Name, Kind)]) -> String -> [(Name, Kind)]
forall a b. (a -> b) -> a -> b
$ Con -> String
nonRecordConstructorMessage Con
con
toSqlField :: (a, Kind) -> Q (a, Kind)
toSqlField (a
fieldName', Kind
ty) = do
Kind
sqlTy <- Kind -> Q Kind
sqlFieldType Kind
ty
(a, Kind) -> Q (a, Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
fieldName', Kind
sqlTy)
makeSqlName :: Name -> Name
makeSqlName :: Name -> Name
makeSqlName Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Sql" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
sqlFieldType :: Type -> Q Type
sqlFieldType :: Kind -> Q Kind
sqlFieldType Kind
fieldType = do
Maybe Kind
maybeSqlType <- Kind -> Q (Maybe Kind)
reifySqlSelectType Kind
fieldType
Kind -> Q Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Q Kind) -> Kind -> Q Kind
forall a b. (a -> b) -> a -> b
$
(Kind -> Maybe Kind -> Kind) -> Maybe Kind -> Kind -> Kind
forall a b c. (a -> b -> c) -> b -> a -> c
flip Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Maybe Kind
maybeSqlType (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
case Kind
fieldType of
AppT (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True)) Kind
_innerType -> Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''SqlExpr) Kind
fieldType
(ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Maybe -> Bool
True))
`AppT` ((ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True))
`AppT` Kind
_innerType) -> Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''SqlExpr) Kind
fieldType
Kind
_ -> (Name -> Kind
ConT ''SqlExpr)
Kind -> Kind -> Kind
`AppT` ((Name -> Kind
ConT ''Value)
Kind -> Kind -> Kind
`AppT` Kind
fieldType)
makeSqlRecord :: RecordInfo -> Q Dec
makeSqlRecord :: RecordInfo -> Q Dec
makeSqlRecord RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
let newConstructor :: Con
newConstructor = Name -> [VarBangType] -> Con
RecC (Name -> Name
makeSqlName Name
constructorName) ((Name, Kind) -> VarBangType
forall a c. (a, c) -> (a, Bang, c)
makeField ((Name, Kind) -> VarBangType) -> [(Name, Kind)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Kind)]
sqlFields)
derivingClauses :: [a]
derivingClauses = []
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
constraints Name
sqlName [TyVarBndr]
typeVarBinders Maybe Kind
kind [Con
newConstructor] [DerivClause]
forall a. [a]
derivingClauses
where
makeField :: (a, c) -> (a, Bang, c)
makeField (a
fieldName', c
fieldType) =
(a
fieldName', SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, c
fieldType)
makeSqlSelectInstance :: RecordInfo -> Q Dec
makeSqlSelectInstance :: RecordInfo -> Q Dec
makeSqlSelectInstance info :: RecordInfo
info@RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
Dec
sqlSelectColsDec' <- RecordInfo -> Q Dec
sqlSelectColsDec RecordInfo
info
Dec
sqlSelectColCountDec' <- RecordInfo -> Q Dec
sqlSelectColCountDec RecordInfo
info
Dec
sqlSelectProcessRowDec' <- RecordInfo -> Q Dec
sqlSelectProcessRowDec RecordInfo
info
let overlap :: Maybe a
overlap = Maybe a
forall a. Maybe a
Nothing
instanceConstraints :: [a]
instanceConstraints = []
instanceType :: Kind
instanceType =
(Name -> Kind
ConT ''SqlSelect)
Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT Name
sqlName)
Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT Name
name)
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
$ Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
overlap Cxt
forall a. [a]
instanceConstraints Kind
instanceType [Dec
sqlSelectColsDec', Dec
sqlSelectColCountDec', Dec
sqlSelectProcessRowDec']
sqlSelectColsDec :: RecordInfo -> Q Dec
sqlSelectColsDec :: RecordInfo -> Q Dec
sqlSelectColsDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
[(Name, Name)]
fieldNames <- [(Name, Kind)]
-> ((Name, Kind) -> Q (Name, Name)) -> Q [(Name, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Kind)]
sqlFields (\(Name
name', Kind
_type) -> do
Name
var <- String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name'
(Name, Name) -> Q (Name, Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name', Name
var))
let fieldPatterns :: [FieldPat]
fieldPatterns :: [FieldPat]
fieldPatterns = [(Name
name', Name -> Pat
VarP Name
var) | (Name
name', Name
var) <- [(Name, Name)]
fieldNames]
joinedFields :: Exp
joinedFields :: Exp
joinedFields =
case (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Name)]
fieldNames of
[] -> [Maybe Exp] -> Exp
TupE []
[Name
f1] -> Name -> Exp
VarE Name
f1
Name
f1 : [Name]
rest ->
let helper :: Exp -> Name -> Exp
helper Exp
lhs Name
field =
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
lhs)
(Name -> Exp
ConE '(:&))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
field)
in (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Name -> Exp
helper (Name -> Exp
VarE Name
f1) [Name]
rest
Name
identInfo <- String -> Q Name
newName String
"identInfo"
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 -> [Clause] -> Dec
FunD
'sqlSelectCols
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[ Name -> Pat
VarP Name
identInfo
, Name -> [FieldPat] -> Pat
RecP Name
sqlName [FieldPat]
fieldPatterns
]
( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
(Name -> Exp
VarE 'sqlSelectCols)
Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE Name
identInfo)
Exp -> Exp -> Exp
`AppE` (Exp -> Exp
ParensE Exp
joinedFields)
)
[]
]
sqlSelectColCountDec :: RecordInfo -> Q Dec
sqlSelectColCountDec :: RecordInfo -> Q Dec
sqlSelectColCountDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
let joinedTypes :: Kind
joinedTypes =
case (Name, Kind) -> Kind
forall a b. (a, b) -> b
snd ((Name, Kind) -> Kind) -> [(Name, Kind)] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Kind)]
sqlFields of
[] -> Int -> Kind
TupleT Int
0
Kind
t1 : Cxt
rest ->
let helper :: Kind -> Kind -> Kind
helper Kind
lhs Kind
ty =
Kind -> Name -> Kind -> Kind
InfixT Kind
lhs ''(:&) Kind
ty
in (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Kind -> Kind -> Kind
helper Kind
t1 Cxt
rest
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 -> [Clause] -> Dec
FunD
'sqlSelectColCount
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[Pat
WildP]
( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'sqlSelectColCount) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
Exp -> Exp
ParensE (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
Exp -> Kind -> Exp
AppTypeE
(Name -> Exp
ConE 'Proxy)
Kind
joinedTypes
)
[]
]
sqlSelectProcessRowDec :: RecordInfo -> Q Dec
sqlSelectProcessRowDec :: RecordInfo -> Q Dec
sqlSelectProcessRowDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
([Stmt]
statements, [(Name, Exp)]
fieldExps) <-
[(Stmt, (Name, Exp))] -> ([Stmt], [(Name, Exp)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Stmt, (Name, Exp))] -> ([Stmt], [(Name, Exp)]))
-> Q [(Stmt, (Name, Exp))] -> Q ([Stmt], [(Name, Exp)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((Name, Kind), (Name, Kind))]
-> (((Name, Kind), (Name, Kind)) -> Q (Stmt, (Name, Exp)))
-> Q [(Stmt, (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(Name, Kind)] -> [(Name, Kind)] -> [((Name, Kind), (Name, Kind))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Kind)]
fields [(Name, Kind)]
sqlFields) (\((Name
fieldName', Kind
fieldType), (Name
_, Kind
sqlType')) -> do
Name
valueName <- String -> Q Name
newName (Name -> String
nameBase Name
fieldName')
Pat
pattern <- Kind -> Name -> Q Pat
sqlSelectProcessRowPat Kind
fieldType Name
valueName
(Stmt, (Name, Exp)) -> Q (Stmt, (Name, Exp))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Pat -> Exp -> Stmt
BindS
Pat
pattern
(Exp -> Kind -> Exp
AppTypeE (Name -> Exp
VarE 'takeColumns) Kind
sqlType')
, (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
fieldName', Name -> Exp
VarE Name
valueName)
))
Name
colsName <- String -> Q Name
newName String
"columns"
Name
processName <- String -> Q Name
newName String
"process"
Exp
bodyExp <- [e|
first (fromString ("Failed to parse " ++ $(lift $ nameBase name) ++ ": ") <>)
(evalStateT $(varE processName) $(varE colsName))
|]
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 -> [Clause] -> Dec
FunD
'sqlSelectProcessRow
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> Pat
VarP Name
colsName]
(Exp -> Body
NormalB Exp
bodyExp)
[ Pat -> Body -> [Dec] -> Dec
ValD
(Name -> Pat
VarP Name
processName)
( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
[Stmt] -> Exp
DoE
#if MIN_VERSION_template_haskell(2,17,0)
Nothing
#endif
([Stmt]
statements [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) (Name -> [(Name, Exp)] -> Exp
RecConE Name
constructorName [(Name, Exp)]
fieldExps)])
)
[]
]
]
sqlSelectProcessRowPat :: Type -> Name -> Q Pat
sqlSelectProcessRowPat :: Kind -> Name -> Q Pat
sqlSelectProcessRowPat Kind
fieldType Name
var = do
Maybe Kind
maybeSqlType <- Kind -> Q (Maybe Kind)
reifySqlSelectType Kind
fieldType
case Maybe Kind
maybeSqlType of
Just Kind
_ -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
var
Maybe Kind
Nothing -> case Kind
fieldType of
AppT (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True)) Kind
_innerType -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
var
(ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Maybe -> Bool
True))
`AppT` ((ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True))
`AppT` Kind
_innerType) -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
var
#if MIN_VERSION_template_haskell(2,18,0)
_ -> pure $ ConP 'Value [] [VarP var]
#else
Kind
_ -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Pat] -> Pat
ConP 'Value [Name -> Pat
VarP Name
var]
#endif
reifySqlSelectType :: Type -> Q (Maybe Type)
reifySqlSelectType :: Kind -> Q (Maybe Kind)
reifySqlSelectType Kind
originalType = do
Name
tyVarName <- String -> Q Name
newName String
"a"
[Dec]
instances <- Name -> Cxt -> Q [Dec]
reifyInstances ''SqlSelect [Name -> Kind
VarT Name
tyVarName, Kind
originalType]
let extractSqlRecord :: Type -> Type -> Maybe Type
extractSqlRecord :: Kind -> Kind -> Maybe Kind
extractSqlRecord Kind
originalTy Kind
instanceTy =
case Kind
instanceTy of
(ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''SqlSelect -> Bool
True))
`AppT` Kind
sqlTy
`AppT` (Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
(==) Kind
originalTy -> Bool
True) -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
sqlTy
Kind
_ -> Maybe Kind
forall a. Maybe a
Nothing
filteredInstances :: [Type]
filteredInstances :: Cxt
filteredInstances =
((Dec -> Maybe Kind) -> [Dec] -> Cxt)
-> [Dec] -> (Dec -> Maybe Kind) -> Cxt
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Dec -> Maybe Kind) -> [Dec] -> Cxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Dec]
instances
(\case InstanceD Maybe Overlap
_overlap
Cxt
_constraints
(Kind -> Kind -> Maybe Kind
extractSqlRecord Kind
originalType -> Just Kind
sqlRecord)
[Dec]
_decs ->
Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
sqlRecord
Dec
_ -> Maybe Kind
forall a. Maybe a
Nothing)
Maybe Kind -> Q (Maybe Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Kind -> Q (Maybe Kind)) -> Maybe Kind -> Q (Maybe Kind)
forall a b. (a -> b) -> a -> b
$ Cxt -> Maybe Kind
forall a. [a] -> Maybe a
listToMaybe Cxt
filteredInstances
takeColumns ::
forall a b.
SqlSelect a b =>
StateT [PersistValue] (Either Text) b
takeColumns :: StateT [PersistValue] (Either Text) b
takeColumns = ([PersistValue] -> Either Text (b, [PersistValue]))
-> StateT [PersistValue] (Either Text) b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\[PersistValue]
pvs ->
let targetColCount :: Int
targetColCount =
Proxy a -> Int
forall a r. SqlSelect a r => Proxy a -> Int
sqlSelectColCount (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
([PersistValue]
target, [PersistValue]
other) =
Int -> [PersistValue] -> ([PersistValue], [PersistValue])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
targetColCount [PersistValue]
pvs
in if [PersistValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PersistValue]
target Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
targetColCount
then do
b
value <- [PersistValue] -> Either Text b
forall a r. SqlSelect a r => [PersistValue] -> Either Text r
sqlSelectProcessRow [PersistValue]
target
(b, [PersistValue]) -> Either Text (b, [PersistValue])
forall a b. b -> Either a b
Right (b
value, [PersistValue]
other)
else Text -> Either Text (b, [PersistValue])
forall a b. a -> Either a b
Left Text
"Insufficient columns when trying to parse a column")
nonRecordConstructorMessage :: Con -> String
nonRecordConstructorMessage :: Con -> String
nonRecordConstructorMessage Con
con =
case Con
con of
(RecC {}) -> String -> String
forall a. HasCallStack => String -> a
error String
"Record constructors are not an error"
(NormalC {}) -> String -> String
helper String
"non-record data constructor"
(InfixC {}) -> String -> String
helper String
"infix constructor"
(ForallC {}) -> String -> String
helper String
"constructor qualified by type variables / class contexts"
(GadtC {}) -> String -> String
helper String
"GADT constructor"
(RecGadtC {}) -> String -> String
helper String
"record GADT constructor"
where
helper :: String -> String
helper String
constructorType =
String
"Esqueleto records can only be derived for record constructors, but "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (Con -> Name
constructorName Con
con)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is a "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constructorType
constructorName :: Con -> Name
constructorName Con
constructor =
case Con
constructor of
(RecC Name
name [VarBangType]
_) -> Name
name
(NormalC Name
name [BangType]
_fields) -> Name
name
(InfixC BangType
_ty1 Name
name BangType
_ty2) -> Name
name
(ForallC [TyVarBndr]
_vars Cxt
_constraints Con
innerConstructor) -> Con -> Name
constructorName Con
innerConstructor
(GadtC [Name]
names [BangType]
_fields Kind
_ret) -> [Name] -> Name
forall a. [a] -> a
head [Name]
names
(RecGadtC [Name]
names [VarBangType]
_fields Kind
_ret) -> [Name] -> Name
forall a. [a] -> a
head [Name]
names