{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
module Database.PostgreSQL.Typed.Relation
( dataPGRelation
) where
import qualified Data.ByteString.Lazy as BSL
import Data.Proxy (Proxy(..))
import qualified Language.Haskell.TH as TH
import Database.PostgreSQL.Typed.Types
import Database.PostgreSQL.Typed.Dynamic
import Database.PostgreSQL.Typed.Protocol
import Database.PostgreSQL.Typed.TypeCache
import Database.PostgreSQL.Typed.TH
class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where
pgRelationName :: Proxy a -> PGName
pgRelationName = PGTypeID (PGRepType a) -> PGName
forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName (PGTypeID (PGRepType a) -> PGName)
-> (Proxy a -> PGTypeID (PGRepType a)) -> Proxy a -> PGName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> PGTypeID (PGRepType a)
forall a. Proxy a -> PGTypeID (PGRepType a)
pgTypeOfProxy
pgColumnNames :: Proxy a -> [PGName]
dataPGRelation :: String
-> PGName
-> (String -> String)
-> TH.DecsQ
dataPGRelation :: String -> PGName -> (String -> String) -> DecsQ
dataPGRelation String
typs PGName
pgtab String -> String
colf = do
(PGName
pgid, [(PGName, Name, Type, Bool)]
cold) <- IO (PGName, [(PGName, Name, Type, Bool)])
-> Q (PGName, [(PGName, Name, Type, Bool)])
forall a. IO a -> Q a
TH.runIO (IO (PGName, [(PGName, Name, Type, Bool)])
-> Q (PGName, [(PGName, Name, Type, Bool)]))
-> IO (PGName, [(PGName, Name, Type, Bool)])
-> Q (PGName, [(PGName, Name, Type, Bool)])
forall a b. (a -> b) -> a -> b
$ (PGTypeConnection -> IO (PGName, [(PGName, Name, Type, Bool)]))
-> IO (PGName, [(PGName, Name, Type, Bool)])
forall a. (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection ((PGTypeConnection -> IO (PGName, [(PGName, Name, Type, Bool)]))
-> IO (PGName, [(PGName, Name, Type, Bool)]))
-> (PGTypeConnection -> IO (PGName, [(PGName, Name, Type, Bool)]))
-> IO (PGName, [(PGName, Name, Type, Bool)])
forall a b. (a -> b) -> a -> b
$ \PGTypeConnection
tpg -> do
[(OID, (PGName, Name, Type, Bool))]
cl <- ([PGValue] -> IO (OID, (PGName, Name, Type, Bool)))
-> [[PGValue]] -> IO [(OID, (PGName, Name, Type, Bool))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\[PGValue
to, PGValue
cn, PGValue
ct, PGValue
cnn] -> do
let c :: PGName
c = PGValue -> PGName
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
cn
n :: Name
n = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
colf (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ PGName -> String
pgNameString PGName
c
o :: OID
o = PGValue -> OID
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
ct
PGName
t <- IO PGName -> (PGName -> IO PGName) -> Maybe PGName -> IO PGName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO PGName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO PGName) -> String -> IO PGName
forall a b. (a -> b) -> a -> b
$ String
"dataPGRelation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
pgtab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": column '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' has unknown type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OID -> String
forall a. Show a => a -> String
show OID
o) PGName -> IO PGName
forall (m :: * -> *) a. Monad m => a -> m a
return
(Maybe PGName -> IO PGName) -> IO (Maybe PGName) -> IO PGName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGTypeConnection -> OID -> IO (Maybe PGName)
lookupPGType PGTypeConnection
tpg OID
o
(OID, (PGName, Name, Type, Bool))
-> IO (OID, (PGName, Name, Type, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (PGValue -> OID
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
to, (PGName
c, Name
n, TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (String -> TyLit) -> String -> TyLit
forall a b. (a -> b) -> a -> b
$ PGName -> String
pgNameString PGName
t), Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PGValue -> Bool
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
cnn)))
([[PGValue]] -> IO [(OID, (PGName, Name, Type, Bool))])
-> ((Int, [[PGValue]]) -> [[PGValue]])
-> (Int, [[PGValue]])
-> IO [(OID, (PGName, Name, Type, Bool))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [[PGValue]]) -> [[PGValue]]
forall a b. (a, b) -> b
snd ((Int, [[PGValue]]) -> IO [(OID, (PGName, Name, Type, Bool))])
-> IO (Int, [[PGValue]]) -> IO [(OID, (PGName, Name, Type, Bool))]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGConnection -> ByteString -> IO (Int, [[PGValue]])
pgSimpleQuery (PGTypeConnection -> PGConnection
pgConnection PGTypeConnection
tpg) ([ByteString] -> ByteString
BSL.fromChunks
[ ByteString
"SELECT reltype, attname, atttypid, attnotnull"
, ByteString
" FROM pg_catalog.pg_attribute"
, ByteString
" JOIN pg_catalog.pg_class ON attrelid = pg_class.oid"
, ByteString
" WHERE attrelid = ", PGName -> ByteString
forall a. PGRep a => a -> ByteString
pgLiteralRep PGName
pgtab, ByteString
"::regclass"
, ByteString
" AND attnum > 0 AND NOT attisdropped"
, ByteString
" ORDER BY attnum"
])
case [(OID, (PGName, Name, Type, Bool))]
cl of
[] -> String -> IO (PGName, [(PGName, Name, Type, Bool)])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (PGName, [(PGName, Name, Type, Bool)]))
-> String -> IO (PGName, [(PGName, Name, Type, Bool)])
forall a b. (a -> b) -> a -> b
$ String
"dataPGRelation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
pgtab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": no columns found"
(OID
to, (PGName, Name, Type, Bool)
_):[(OID, (PGName, Name, Type, Bool))]
_ -> do
PGName
tt <- IO PGName -> (PGName -> IO PGName) -> Maybe PGName -> IO PGName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO PGName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO PGName) -> String -> IO PGName
forall a b. (a -> b) -> a -> b
$ String
"dataPGRelation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
pgtab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": table type not found (you may need to use reloadTPGTypes or adjust search_path)") PGName -> IO PGName
forall (m :: * -> *) a. Monad m => a -> m a
return
(Maybe PGName -> IO PGName) -> IO (Maybe PGName) -> IO PGName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGTypeConnection -> OID -> IO (Maybe PGName)
lookupPGType PGTypeConnection
tpg OID
to
(PGName, [(PGName, Name, Type, Bool)])
-> IO (PGName, [(PGName, Name, Type, Bool)])
forall (m :: * -> *) a. Monad m => a -> m a
return (PGName
tt, ((OID, (PGName, Name, Type, Bool)) -> (PGName, Name, Type, Bool))
-> [(OID, (PGName, Name, Type, Bool))]
-> [(PGName, Name, Type, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (OID, (PGName, Name, Type, Bool)) -> (PGName, Name, Type, Bool)
forall a b. (a, b) -> b
snd [(OID, (PGName, Name, Type, Bool))]
cl)
[(Name, Type, Bool)]
cols <- ((PGName, Name, Type, Bool) -> Q (Name, Type, Bool))
-> [(PGName, Name, Type, Bool)] -> Q [(Name, Type, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(PGName
c, Name
_, Type
t, Bool
nn) -> do
Name
v <- String -> Q Name
TH.newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ PGName -> String
pgNameString PGName
c
(Name, Type, Bool) -> Q (Name, Type, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
v, Type
t, Bool
nn))
[(PGName, Name, Type, Bool)]
cold
let typl :: Type
typl = TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (String -> TyLit) -> String -> TyLit
forall a b. (a -> b) -> a -> b
$ PGName -> String
pgNameString PGName
pgid)
encfun :: Name -> Dec
encfun Name
f = Name -> [Clause] -> Dec
TH.FunD Name
f [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP, Name -> [Pat] -> Pat
TH.ConP Name
typn (((Name, Type, Bool) -> Pat) -> [(Name, Type, Bool)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
v, Type
_, Bool
_) -> Name -> Pat
TH.VarP Name
v) [(Name, Type, Bool)]
cols)]
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Exp
pgcall Name
f Type
rect Exp -> Exp -> Exp
`TH.AppE`
(Name -> Exp
TH.ConE 'PGRecord Exp -> Exp -> Exp
`TH.AppE` [Exp] -> Exp
TH.ListE (((Name, Type, Bool) -> Exp) -> [(Name, Type, Bool)] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> (Name, Type, Bool) -> Exp
colenc Name
f) [(Name, Type, Bool)]
cols)))
[] ]
Name
dv <- String -> Q Name
TH.newName String
"x"
Name
tv <- String -> Q Name
TH.newName String
"t"
Name
ev <- String -> Q Name
TH.newName String
"e"
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$
[ Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD
[]
Name
typn
[]
#if MIN_VERSION_template_haskell(2,11,0)
Maybe Type
forall a. Maybe a
Nothing
#endif
[ Name -> [VarBangType] -> Con
TH.RecC Name
typn ([VarBangType] -> Con) -> [VarBangType] -> Con
forall a b. (a -> b) -> a -> b
$ ((PGName, Name, Type, Bool) -> VarBangType)
-> [(PGName, Name, Type, Bool)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map (\(PGName
_, Name
n, Type
t, Bool
nn) ->
( Name
n
#if MIN_VERSION_template_haskell(2,11,0)
, SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang SourceUnpackedness
TH.NoSourceUnpackedness SourceStrictness
TH.NoSourceStrictness
#else
, TH.NotStrict
#endif
, (if Bool
nn then (Name -> Type
TH.ConT ''Maybe Type -> Type -> Type
`TH.AppT`) else Type -> Type
forall a. a -> a
id)
(Name -> Type
TH.ConT ''PGVal Type -> Type -> Type
`TH.AppT` Type
t)))
[(PGName, Name, Type, Bool)]
cold
]
[]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGType Type -> Type -> Type
`TH.AppT` Type
typl)
[ Name -> Type -> Type -> Dec
tySynInstD ''PGVal Type
typl Type
typt
]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGParameter Type -> Type -> Type
`TH.AppT` Type
typl Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> Dec
encfun 'pgEncode
, Name -> Dec
encfun 'pgLiteral
]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGColumn Type -> Type -> Type
`TH.AppT` Type
typl Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> [Clause] -> Dec
TH.FunD 'pgDecode [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP, Name -> Pat
TH.VarP Name
dv]
([(Guard, Exp)] -> Body
TH.GuardedB
[ ([Stmt] -> Guard
TH.PatG [Pat -> Exp -> Stmt
TH.BindS
(Name -> [Pat] -> Pat
TH.ConP 'PGRecord [[Pat] -> Pat
TH.ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ ((Name, Type, Bool) -> Pat) -> [(Name, Type, Bool)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type, Bool) -> Pat
forall b. (Name, b, Bool) -> Pat
colpat [(Name, Type, Bool)]
cols])
(Name -> Type -> Exp
pgcall 'pgDecode Type
rect Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
dv)]
, (Exp -> (Name, Type, Bool) -> Exp)
-> Exp -> [(Name, Type, Bool)] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
f -> Exp -> Exp -> Exp
TH.AppE Exp
f (Exp -> Exp)
-> ((Name, Type, Bool) -> Exp) -> (Name, Type, Bool) -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type, Bool) -> Exp
coldec) (Name -> Exp
TH.ConE Name
typn) [(Name, Type, Bool)]
cols)
, (Exp -> Guard
TH.NormalG (Name -> Exp
TH.ConE 'True)
, Name -> Exp
TH.VarE 'error Exp -> Exp -> Exp
`TH.AppE` Lit -> Exp
TH.LitE (String -> Lit
TH.StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"pgDecode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": NULL in not null record column"))
])
[] ]
]
#if MIN_VERSION_template_haskell(2,11,0)
, Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
TH.InstanceD (Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
TH.Overlapping) [] (Name -> Type
TH.ConT ''PGColumn Type -> Type -> Type
`TH.AppT` Type
typl Type -> Type -> Type
`TH.AppT` (Name -> Type
TH.ConT ''Maybe Type -> Type -> Type
`TH.AppT` Type
typt))
[ Name -> [Clause] -> Dec
TH.FunD 'pgDecode [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP, Name -> Pat
TH.VarP Name
dv]
([(Guard, Exp)] -> Body
TH.GuardedB
[ ([Stmt] -> Guard
TH.PatG [Pat -> Exp -> Stmt
TH.BindS
(Name -> [Pat] -> Pat
TH.ConP 'PGRecord [[Pat] -> Pat
TH.ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ ((Name, Type, Bool) -> Pat) -> [(Name, Type, Bool)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type, Bool) -> Pat
forall b. (Name, b, Bool) -> Pat
colpat [(Name, Type, Bool)]
cols])
(Name -> Type -> Exp
pgcall 'pgDecode Type
rect Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
dv)]
, Name -> Exp
TH.ConE 'Just Exp -> Exp -> Exp
`TH.AppE` (Exp -> (Name, Type, Bool) -> Exp)
-> Exp -> [(Name, Type, Bool)] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
f -> Exp -> Exp -> Exp
TH.AppE Exp
f (Exp -> Exp)
-> ((Name, Type, Bool) -> Exp) -> (Name, Type, Bool) -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type, Bool) -> Exp
coldec) (Name -> Exp
TH.ConE Name
typn) [(Name, Type, Bool)]
cols)
, (Exp -> Guard
TH.NormalG (Name -> Exp
TH.ConE 'True)
, Name -> Exp
TH.ConE 'Nothing)
])
[] ]
, Name -> [Clause] -> Dec
TH.FunD 'pgDecodeValue
[ [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP, Pat
TH.WildP, Name -> [Pat] -> Pat
TH.ConP 'PGNullValue []]
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.ConE 'Nothing)
[]
, [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP, Name -> Pat
TH.VarP Name
tv, Name -> [Pat] -> Pat
TH.ConP 'PGTextValue [Name -> Pat
TH.VarP Name
dv]]
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'pgDecode Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
tv Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
dv)
[]
, [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> Pat
TH.VarP Name
ev, Name -> Pat
TH.VarP Name
tv, Name -> [Pat] -> Pat
TH.ConP 'PGBinaryValue [Name -> Pat
TH.VarP Name
dv]]
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'pgDecodeBinary Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
ev Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
tv Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
dv)
[]
]
]
#endif
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGRep Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> Type -> Type -> Dec
tySynInstD ''PGRepType Type
typt Type
typl
]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGRecordType Type -> Type -> Type
`TH.AppT` Type
typl) []
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGRelation Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> [Clause] -> Dec
TH.FunD 'pgRelationName [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP]
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ PGName -> Exp
namelit PGName
pgtab)
[] ]
, Name -> [Clause] -> Dec
TH.FunD 'pgColumnNames [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP]
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TH.ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ ((PGName, Name, Type, Bool) -> Exp)
-> [(PGName, Name, Type, Bool)] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(PGName
c, Name
_, Type
_, Bool
_) -> PGName -> Exp
namelit PGName
c) [(PGName, Name, Type, Bool)]
cold)
[] ]
]
, Name -> Type -> Dec
TH.SigD (String -> Name
TH.mkName (String
"uncurry" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs)) (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Type
TH.ArrowT Type -> Type -> Type
`TH.AppT`
(Type -> (Name, Type, Bool) -> Type)
-> Type -> [(Name, Type, Bool)] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
f (Name
_, Type
t, Bool
n) -> Type
f Type -> Type -> Type
`TH.AppT`
(if Bool
n then (Name -> Type
TH.ConT ''Maybe Type -> Type -> Type
`TH.AppT`) else Type -> Type
forall a. a -> a
id)
(Name -> Type
TH.ConT ''PGVal Type -> Type -> Type
`TH.AppT` Type
t))
(Name -> Type
TH.ConT (Int -> Name
TH.tupleTypeName ([(Name, Type, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Type, Bool)]
cols)))
[(Name, Type, Bool)]
cols Type -> Type -> Type
`TH.AppT` Type
typt
, Name -> [Clause] -> Dec
TH.FunD (String -> Name
TH.mkName (String
"uncurry" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs))
[ [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> [Pat] -> Pat
TH.ConP (Int -> Name
TH.tupleDataName ([(Name, Type, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Type, Bool)]
cols)) (((Name, Type, Bool) -> Pat) -> [(Name, Type, Bool)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
v, Type
_, Bool
_) -> Name -> Pat
TH.VarP Name
v) [(Name, Type, Bool)]
cols)]
(Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ (Exp -> (Name, Type, Bool) -> Exp)
-> Exp -> [(Name, Type, Bool)] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
f (Name
v, Type
_, Bool
_) -> Exp
f Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
v) (Name -> Exp
TH.ConE Name
typn) [(Name, Type, Bool)]
cols)
[]
]
, Pragma -> Dec
TH.PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP (Name -> AnnTarget
TH.TypeAnnotation Name
typn) (Exp -> Pragma) -> Exp -> Pragma
forall a b. (a -> b) -> a -> b
$ PGName -> Exp
namelit PGName
pgid
, Pragma -> Dec
TH.PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP (Name -> AnnTarget
TH.ValueAnnotation Name
typn) (Exp -> Pragma) -> Exp -> Pragma
forall a b. (a -> b) -> a -> b
$ PGName -> Exp
namelit PGName
pgid
] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ ((PGName, Name, Type, Bool) -> Dec)
-> [(PGName, Name, Type, Bool)] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (\(PGName
c, Name
n, Type
_, Bool
_) ->
Pragma -> Dec
TH.PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP (Name -> AnnTarget
TH.ValueAnnotation Name
n) (Exp -> Pragma) -> Exp -> Pragma
forall a b. (a -> b) -> a -> b
$ PGName -> Exp
namelit PGName
c) [(PGName, Name, Type, Bool)]
cold
where
typn :: Name
typn = String -> Name
TH.mkName String
typs
typt :: Type
typt = Name -> Type
TH.ConT Name
typn
instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
TH.InstanceD
#if MIN_VERSION_template_haskell(2,11,0)
Maybe Overlap
forall a. Maybe a
Nothing
#endif
tySynInstD :: Name -> Type -> Type -> Dec
tySynInstD Name
c Type
l Type
t = TySynEqn -> Dec
TH.TySynInstD
#if MIN_VERSION_template_haskell(2,15,0)
(TySynEqn -> Dec) -> TySynEqn -> Dec
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TH.TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
c) Type
l)
#else
c $ TH.TySynEqn [l]
#endif
Type
t
pgcall :: Name -> Type -> Exp
pgcall Name
f Type
t = Name -> Exp
TH.VarE Name
f Exp -> Exp -> Exp
`TH.AppE`
(Name -> Exp
TH.ConE 'PGTypeProxy Exp -> Type -> Exp
`TH.SigE`
(Name -> Type
TH.ConT ''PGTypeID Type -> Type -> Type
`TH.AppT` Type
t))
colenc :: Name -> (Name, Type, Bool) -> Exp
colenc Name
f (Name
v, Type
t, Bool
False) = Name -> Exp
TH.ConE 'Just Exp -> Exp -> Exp
`TH.AppE` (Name -> Type -> Exp
pgcall Name
f Type
t Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
v)
colenc Name
f (Name
v, Type
t, Bool
True) = Name -> Exp
TH.VarE 'fmap Exp -> Exp -> Exp
`TH.AppE` Name -> Type -> Exp
pgcall Name
f Type
t Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
v
colpat :: (Name, b, Bool) -> Pat
colpat (Name
v, b
_, Bool
False) = Name -> [Pat] -> Pat
TH.ConP 'Just [Name -> Pat
TH.VarP Name
v]
colpat (Name
v, b
_, Bool
True) = Name -> Pat
TH.VarP Name
v
coldec :: (Name, Type, Bool) -> Exp
coldec (Name
v, Type
t, Bool
False) = Name -> Type -> Exp
pgcall 'pgDecode Type
t Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
v
coldec (Name
v, Type
t, Bool
True) = Name -> Exp
TH.VarE 'fmap Exp -> Exp -> Exp
`TH.AppE` Name -> Type -> Exp
pgcall 'pgDecode Type
t Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
v
rect :: Type
rect = TyLit -> Type
TH.LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
TH.StrTyLit String
"record"
namelit :: PGName -> Exp
namelit PGName
n = Name -> Exp
TH.ConE 'PGName Exp -> Exp -> Exp
`TH.AppE`
[Exp] -> Exp
TH.ListE ((Word8 -> Exp) -> [Word8] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Lit -> Exp
TH.LitE (Lit -> Exp) -> (Word8 -> Lit) -> Word8 -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
TH.IntegerL (Integer -> Lit) -> (Word8 -> Integer) -> Word8 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> [Exp]) -> [Word8] -> [Exp]
forall a b. (a -> b) -> a -> b
$ PGName -> [Word8]
pgNameBytes PGName
n)