{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
-- |
-- Module: Database.PostgreSQL.Typed.Relation
-- Copyright: 2016 Dylan Simon
-- 
-- Automatically create data types based on tables and other relations.

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

-- |Data types that are based on database relations.
-- Normally these instances are created using 'dataPGRelation'.
class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where
  -- |Database name of table/relation (i.e., second argument to 'dataPGRelation').  Normally this is the same as @'pgTypeID' . 'pgTypeOfProxy'@, but this preserves any specified schema qualification.
  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
  -- |Database names of columns.
  pgColumnNames :: Proxy a -> [PGName]

-- |Create a new data type corresponding to the given PostgreSQL relation.
-- For example, if you have @CREATE TABLE foo (abc integer NOT NULL, def text)@, then
-- @dataPGRelation \"Foo\" \"foo\" (\"foo_\"++)@ will be equivalent to:
-- 
-- > data Foo = Foo{ foo_abc :: PGVal "integer", foo_def :: Maybe (PGVal "text") }
-- > instance PGType "foo" where PGVal "foo" = Foo
-- > instance PGParameter "foo" Foo where ...
-- > instance PGColumn "foo" Foo where ...
-- > instance PGColumn "foo" (Maybe Foo) where ... -- to handle NULL in not null columns
-- > instance PGRep Foo where PGRepType = "foo"
-- > instance PGRecordType "foo"
-- > instance PGRelation Foo where pgColumnNames _ = ["abc", "def"]
-- > uncurryFoo :: (PGVal "integer", Maybe (PGVal "text")) -> Foo
--
-- (Note that @PGVal "integer" = Int32@ and @PGVal "text" = Text@ by default.)
-- This provides instances for marshalling the corresponding composite/record types, e.g., using @SELECT foo.*::foo FROM foo@.
-- If you want any derived instances, you'll need to create them yourself using StandaloneDeriving.
--
-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds, TypeFamilies, PatternGuards
dataPGRelation :: String -- ^ Haskell type and constructor to create
  -> PGName -- ^ PostgreSQL table/relation name
  -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_"++)@ (input is 'pgNameString')
  -> 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)