{-# LANGUAGE CPP #-}
module Composite.Opaleye.TH where
import Control.Lens ((<&>))
import qualified Data.ByteString.Char8 as BSC8
import Data.Maybe (fromMaybe)
import Data.Profunctor.Product.Default (Default, def)
import Data.Traversable (for)
import Database.PostgreSQL.Simple (ResultError(ConversionFailed, Incompatible, UnexpectedNull))
import Database.PostgreSQL.Simple.FromField (FromField, fromField, typename, returnError)
import Language.Haskell.TH
( Q, Name, mkName, nameBase, newName, pprint, reify
, Info(TyConI), Dec(DataD), Con(NormalC)
, conT
, dataD, instanceD
, lamE, varE, caseE, conE
, conP, varP, wildP, litP, stringL
, caseE, match
, funD, clause
, normalB, normalGE, guardedB
, cxt
)
import Language.Haskell.TH.Syntax (lift)
import Opaleye
( Column, DefaultFromField, ToFields, fromPGSFromField, defaultFromField
)
import Opaleye.Internal.PGTypes (IsSqlType, showSqlType, literalColumn)
import Opaleye.Internal.HaskellDB.PrimQuery (Literal(StringLit))
deriveOpaleyeEnum :: Name -> String -> (String -> Maybe String) -> Q [Dec]
deriveOpaleyeEnum :: Name -> String -> (String -> Maybe String) -> Q [Dec]
deriveOpaleyeEnum Name
hsName String
sqlName String -> Maybe String
hsConToSqlValue = do
let sqlTypeName :: Name
sqlTypeName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"PG" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
hsName
sqlType :: TypeQ
sqlType = Name -> TypeQ
conT Name
sqlTypeName
hsType :: TypeQ
hsType = Name -> TypeQ
conT Name
hsName
[Con]
rawCons <- Name -> Q Info
reify Name
hsName Q Info -> (Info -> Q [Con]) -> Q [Con]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
TyConI (DataD Cxt
_cxt Name
_name [TyVarBndr]
_tvVarBndrs Maybe Kind
_maybeKind [Con]
cons [DerivClause]
_derivingCxt) ->
[Con] -> Q [Con]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cons
Info
other ->
String -> Q [Con]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Con]) -> String -> Q [Con]
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
hsName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to name a data declaration, not:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a. Ppr a => a -> String
pprint Info
other
[Name]
nullaryCons <- [Con] -> (Con -> Q Name) -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
rawCons ((Con -> Q Name) -> Q [Name]) -> (Con -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \ case
NormalC Name
conName [] ->
Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
conName
Con
other ->
String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"expected every constructor of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
hsName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to be a regular nullary constructor, not:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a. Ppr a => a -> String
pprint Con
other
let conPairs :: [(Name, String)]
conPairs = [Name]
nullaryCons [Name] -> (Name -> (Name, String)) -> [(Name, String)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ Name
conName ->
(Name
conName, String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Name -> String
nameBase Name
conName) (String -> Maybe String
hsConToSqlValue (Name -> String
nameBase Name
conName)))
Dec
sqlTypeDecl <-
CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD
([TypeQ] -> CxtQ
cxt [])
Name
sqlTypeName
[]
Maybe Kind
forall a. Maybe a
Nothing
[]
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(cxt [])
#endif
Dec
isSqlTypeInst <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) [t| IsSqlType $sqlType |] ([DecQ] -> DecQ) -> (DecQ -> [DecQ]) -> DecQ -> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
:[]) (DecQ -> DecQ) -> DecQ -> DecQ
forall a b. (a -> b) -> a -> b
$ do
Name -> [ClauseQ] -> DecQ
funD 'showSqlType
[ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
[PatQ
wildP]
(ExpQ -> BodyQ
normalB (String -> ExpQ
forall t. Lift t => t -> ExpQ
lift String
sqlName))
[]
]
Dec
fromFieldInst <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) [t| FromField $hsType |] ([DecQ] -> DecQ) -> (DecQ -> [DecQ]) -> DecQ -> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
:[]) (DecQ -> DecQ) -> DecQ -> DecQ
forall a b. (a -> b) -> a -> b
$ do
Name
field <- String -> Q Name
newName String
"field"
Name
mbs <- String -> Q Name
newName String
"mbs"
Name
tname <- String -> Q Name
newName String
"tname"
Name
other <- String -> Q Name
newName String
"other"
let bodyCase :: ExpQ
bodyCase = ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
mbs) ([MatchQ] -> ExpQ) -> [MatchQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
[ PatQ -> BodyQ -> [DecQ] -> MatchQ
match
PatQ
wildP
([Q (Guard, Exp)] -> BodyQ
guardedB [ ExpQ -> ExpQ -> Q (Guard, Exp)
normalGE [| $(varE tname) /= $(lift sqlName) |]
[| returnError Incompatible $(varE field) "" |] ])
[]
] [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++
(
[(Name, String)]
conPairs [(Name, String)] -> ((Name, String) -> MatchQ) -> [MatchQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ (Name
conName, String
value) ->
PatQ -> BodyQ -> [DecQ] -> MatchQ
match
[p| Just $(litP $ stringL value) |]
(ExpQ -> BodyQ
normalB [| pure $(conE conName) |])
[]
) [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++
[ PatQ -> BodyQ -> [DecQ] -> MatchQ
match
[p| Just $(varP other) |]
(ExpQ -> BodyQ
normalB [| returnError ConversionFailed $(varE field) ("Unexpected " <> $(lift sqlName) <> " value: " <> BSC8.unpack $(varE other)) |])
[]
, PatQ -> BodyQ -> [DecQ] -> MatchQ
match
[p| Nothing |]
(ExpQ -> BodyQ
normalB [| returnError UnexpectedNull $(varE field) "" |])
[]
]
Name -> [ClauseQ] -> DecQ
funD 'fromField
[ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
[Name -> PatQ
varP Name
field, Name -> PatQ
varP Name
mbs]
(ExpQ -> BodyQ
normalB [|
do
$(varP tname) <- typename $(varE field)
$bodyCase
|])
[]
]
Dec
defaultFromFieldInst <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) [t| DefaultFromField $sqlType $hsType |] ([DecQ] -> DecQ) -> (DecQ -> [DecQ]) -> DecQ -> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
:[]) (DecQ -> DecQ) -> DecQ -> DecQ
forall a b. (a -> b) -> a -> b
$
Name -> [ClauseQ] -> DecQ
funD 'defaultFromField
[ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
[]
(ExpQ -> BodyQ
normalB [| fromPGSFromField |])
[]
]
Dec
defaultInst <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) [t| Default ToFields $hsType (Column $sqlType) |] ([DecQ] -> DecQ) -> (DecQ -> [DecQ]) -> DecQ -> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
:[]) (DecQ -> DecQ) -> DecQ -> DecQ
forall a b. (a -> b) -> a -> b
$ do
Name
s <- String -> Q Name
newName String
"s"
let body :: ExpQ
body = [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
s] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
s) ([MatchQ] -> ExpQ) -> [MatchQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
[(Name, String)]
conPairs [(Name, String)] -> ((Name, String) -> MatchQ) -> [MatchQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ (Name
conName, String
value) ->
PatQ -> BodyQ -> [DecQ] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
conName [])
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
forall t. Lift t => t -> ExpQ
lift String
value)
[]
Name -> [ClauseQ] -> DecQ
funD 'def
[ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
[]
(ExpQ -> BodyQ
normalB [| ToFields (literalColumn . StringLit . $body) |])
[]
]
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sqlTypeDecl, Dec
isSqlTypeInst, Dec
fromFieldInst, Dec
defaultFromFieldInst, Dec
defaultInst]