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

module Preql.FromSql.TH where

import Preql.FromSql.Class
import Preql.QuasiQuoter.Common (alphabet)
import Preql.Wire.Internal

import GHC.TypeNats
import Language.Haskell.TH

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 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) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
names)
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Name] -> Type -> Name -> Int -> Dec
fromSqlDecl [Name]
names Type
tuple (Int -> Name
tupleDataName Int
n) Int
n]

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
VarT Name
typeN) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyVars)
                (Name
conN, Int
fieldCount) = case [Con]
constructors of
                    [NormalC Name
con [BangType]
elems] -> (Name
con, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
elems)
                    [RecC Name
con [VarBangType]
fields] -> (Name
con, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
fields)
                    [InfixC BangType
_ Name
con BangType
_] -> (Name
con, Int
2)
                    [Con
_] -> String -> (Name, Int)
forall a. HasCallStack => String -> a
error String
"deriveFromSql does not handle GADTs or constructors with class constraints"
                    [Con]
_ -> String -> (Name, Int)
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 [[Name] -> Type -> Name -> Int -> Dec
fromSqlDecl [Name]
tyVars Type
targetTy Name
conN Int
fieldCount]
        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)

tyVarName :: TyVarBndr -> Name
tyVarName :: TyVarBndr -> Name
tyVarName = \case
    PlainTV Name
name -> Name
name
    KindedTV Name
name Type
_k -> Name
name


fromSqlDecl :: [Name] -> Type -> Name -> Int -> Dec
fromSqlDecl :: [Name] -> Type -> Name -> Int -> Dec
fromSqlDecl [Name]
tyVars Type
targetTy Name
constructor Int
fieldCount =
    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` Name -> Type
VarT Name
n | Name
n <- [Name]
tyVars ]
        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` Name -> Type
VarT Name
n | Name
n <- [Name]
tyVars ])
        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 Int
fieldCount (Name -> Exp
VarE 'fromSql))))
            [] -- no where clause on the fromSql definition