{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Construct FromSql instances

module Preql.FromSql.TH where

import Preql.FromSql.Class
import Preql.FromSql.Tuple
import Preql.QuasiQuoter.Common (alphabet)
import Preql.Wire.Errors (PgType(Oid))
import Preql.Wire.Internal
import qualified Preql.Wire.TypeInfo.Static as OID

import GHC.TypeNats
import Language.Haskell.TH
import qualified PostgreSQL.Binary.Decoding as PGB

-- | instance (FromSql a, FromSql b) => FromSql (a, b)
deriveFromSqlTuple :: Int -> Q [Dec]
deriveFromSqlTuple :: Int -> Q [Dec]
deriveFromSqlTuple Int
n = do
    [Name]
names <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Q Name
newName (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n [String]
alphabet)
    let
      fields :: [Type]
fields = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
names
      tuple :: Type
tuple = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n) [Type]
fields
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type -> Name -> [Type] -> Dec
fromSqlDecl Type
tuple (Int -> Name
tupleDataName Int
n) [Type]
fields]

-- | derive a 'FromSql' instance for a record type
-- (field names are not required, but there must be only one constructor)
deriveFromSql :: Name -> Q [Dec]
deriveFromSql :: Name -> Q [Dec]
deriveFromSql Name
tyName = do
    Info
info <- Name -> Q Info
reify Name
tyName
    case Info
info of
        TyConI (DataD [Type]
_cxt Name
typeN [TyVarBndr]
binders Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving) ->
            let
                tyVars :: [Name]
tyVars = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarName [TyVarBndr]
binders
                targetTy :: Type
targetTy = (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
typeN) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyVars)
                (Name
conN, [Type]
fieldTypes) = case [Con]
constructors of
                    [NormalC Name
con [BangType]
elems] -> (Name
con, [Type
ty | (Bang
_, Type
ty) <- [BangType]
elems])
                    [RecC Name
con [VarBangType]
fields] -> (Name
con, [Type
ty | (Name
_, Bang
_, Type
ty) <- [VarBangType]
fields])
                    [InfixC (Bang
_, Type
t1) Name
con (Bang
_, Type
t2)] -> (Name
con, [Type
t1, Type
t2])
                    [Con
_] -> String -> (Name, [Type])
forall a. HasCallStack => String -> a
error String
"deriveFromSql does not handle GADTs or constructors with class constraints"
                    [Con]
_ -> String -> (Name, [Type])
forall a. HasCallStack => String -> a
error String
"deriveFromSql does not handle sum types"
            in [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type -> Name -> [Type] -> Dec
fromSqlDecl Type
targetTy Name
conN [Type]
fieldTypes]
        Info
_ -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String
"deriveFromSql only handles type names, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
tyName)

#if MIN_VERSION_template_haskell(2,17,0)
tyVarName :: TyVarBndr () -> Name
tyVarName = \case
    PlainTV name () -> name
    KindedTV name () _k -> name
#else
tyVarName :: TyVarBndr -> Name
tyVarName :: TyVarBndr -> Name
tyVarName = \case
    PlainTV Name
name -> Name
name
    KindedTV Name
name Type
_k -> Name
name
#endif


fromSqlDecl :: Type -> Name -> [Type] -> Dec
fromSqlDecl :: Type -> Name -> [Type] -> Dec
fromSqlDecl Type
targetTy Name
constructor [Type]
fields =
    Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context Type
instanceHead [TySynEqn -> Dec
TySynInstD TySynEqn
width, Dec
method] where
        context :: [Type]
context = [ Name -> Type
ConT ''FromSql Type -> Type -> Type
`AppT` Type
ty | Type
ty <- [Type]
fields, Type -> Bool
hasTyVar Type
ty ]
        instanceHead :: Type
instanceHead = Name -> Type
ConT ''FromSql Type -> Type -> Type
`AppT` Type
targetTy
        width :: TySynEqn
width = Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing
            (Name -> Type
ConT ''Width Type -> Type -> Type
`AppT` Type
targetTy)
            ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
a Type
b -> Name -> Type
ConT ''(+) Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` Type
b) (TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
0))
                [ Name -> Type
ConT ''Width Type -> Type -> Type
`AppT` Type
ty | Type
ty <- [Type]
fields ])
        method :: Dec
method = Pat -> Body -> [Dec] -> Dec
ValD
            (Name -> Pat
VarP 'fromSql)
            (Exp -> Body
NormalB ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                      (\Exp
rowDecoder Exp
field -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
rowDecoder) (Name -> Exp
VarE 'applyDecoder) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
field))
                      (Name -> Exp
VarE 'pureDecoder Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
constructor)
                      (Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields) (Name -> Exp
VarE 'fromSql))))
            [] -- no where clause on the fromSql definition

-- instance (FromSqlField a, FromSqlField b) => FromSqlField (Tuple (a, b))
-- instance (FromSqlField a, FromSqlField b) => FromSql (Tuple (a, b))
deriveFromSqlFieldTuple :: Int -> Q [Dec]
deriveFromSqlFieldTuple :: Int -> Q [Dec]
deriveFromSqlFieldTuple Int
n = do
  [Name]
names <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Q Name
newName (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n [String]
alphabet)
  Exp
fieldOid <- [e| Oid OID.recordOid OID.array_recordOid |]
  let
    fields :: [Type]
fields = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
names
    tuple :: Type
tuple = Name -> Type
ConT ''Tuple Type -> Type -> Type
`AppT` (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n) [Type]
fields
    context :: [Type]
context = [ Name -> Type
ConT ''FromSqlField Type -> Type -> Type
`AppT` Type
ty | Type
ty <- [Type]
fields ]
    width :: TySynEqn
width = Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Name -> Type
ConT ''Width Type -> Type -> Type
`AppT` Type
tuple) (TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
1))
    tupleSizeE :: Exp
tupleSizeE = Lit -> Exp
LitE  (Integer -> Lit
IntegerL (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n))
    parser :: Exp
parser = Name -> Exp
VarE 'fmap Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'Tuple Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE 'composite Exp -> Exp -> Exp
`AppE` Exp
tupleSizeE Exp -> Exp -> Exp
`AppE` (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
             (\Exp
parser Exp
field -> Name -> Exp
VarE '(<*>) Exp -> Exp -> Exp
`AppE` Exp
parser Exp -> Exp -> Exp
`AppE` Exp
field)
             (Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE (Int -> Name
tupleDataName Int
n))
             (Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
n (Name -> Exp
VarE 'valueComposite Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE 'fromSqlField)))
    method :: Dec
method = Pat -> Body -> [Dec] -> Dec
ValD
      (Name -> Pat
VarP 'fromSqlField)
      (Exp -> Body
NormalB (Name -> Exp
ConE 'FieldDecoder Exp -> Exp -> Exp
`AppE` Exp
fieldOid Exp -> Exp -> Exp
`AppE` Exp
parser))
      []
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context (Name -> Type
ConT ''FromSqlField Type -> Type -> Type
`AppT` Type
tuple) [Dec
method]
    , Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context (Name -> Type
ConT ''FromSql Type -> Type -> Type
`AppT` Type
tuple) [ ] ]


hasTyVar :: Type -> Bool
hasTyVar :: Type -> Bool
hasTyVar = \case
  VarT Name
_ -> Bool
True
  ForallT [TyVarBndr]
_ [Type]
_ Type
ty -> Type -> Bool
hasTyVar Type
ty
#if MIN_VERSION_template_haskell(2,16,0)
  ForallVisT [TyVarBndr]
_ Type
ty -> Type -> Bool
hasTyVar Type
ty
#endif
  AppT Type
t1 Type
t2 -> Type -> Bool
hasTyVar Type
t1 Bool -> Bool -> Bool
|| Type -> Bool
hasTyVar Type
t2
  AppKindT Type
ty Type
_ -> Type -> Bool
hasTyVar Type
ty
  SigT Type
ty Type
_ -> Type -> Bool
hasTyVar Type
ty
  InfixT Type
t1 Name
_ Type
t2 -> Type -> Bool
hasTyVar Type
t1 Bool -> Bool -> Bool
|| Type -> Bool
hasTyVar Type
t2
  UInfixT Type
t1 Name
_ Type
t2 -> Type -> Bool
hasTyVar Type
t1 Bool -> Bool -> Bool
|| Type -> Bool
hasTyVar Type
t2
  ParensT Type
ty -> Type -> Bool
hasTyVar Type
ty
  ImplicitParamT String
_ Type
ty -> Type -> Bool
hasTyVar Type
ty
  Type
_ -> Bool
False