{-# LANGUAGE CPP #-}
{-# 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
      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]

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)

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


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

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