{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Database.Bolt.Extras.Template.Internal.Converters
(
makeNodeLike
, makeNodeLikeWith
, makeURelationLike
, makeURelationLikeWith
) where
import Data.Map.Strict (fromList, member, notMember, (!))
import Data.Text (Text, pack, unpack)
import Database.Bolt (Node (..), URelationship (..), Value (..), IsValue(..), RecordValue(..))
import Database.Bolt.Extras (Labels (..),
NodeLike (..),
Properties (..),
URelationLike (..))
import Database.Bolt.Extras.Utils (currentLoc, dummyId)
import Instances.TH.Lift ()
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import GHC.Stack (HasCallStack)
tupE' :: [Exp] -> Exp
#if MIN_VERSION_template_haskell(2, 16, 0)
tupE' :: [Exp] -> Exp
tupE' = [Maybe Exp] -> Exp
TupE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#else
tupE' = TupE
#endif
data BiClassInfo = BiClassInfo { BiClassInfo -> Name
className :: Name
, BiClassInfo -> Name
dataName :: Name
, BiClassInfo -> Name
classToFun :: Name
, BiClassInfo -> Name
classFromFun :: Name
}
nodeLikeClass :: BiClassInfo
nodeLikeClass :: BiClassInfo
nodeLikeClass = BiClassInfo { className :: Name
className = ''NodeLike
, dataName :: Name
dataName = 'Node
, classToFun :: Name
classToFun = 'toNode
, classFromFun :: Name
classFromFun = 'fromNode
}
uRelationLikeClass :: BiClassInfo
uRelationLikeClass :: BiClassInfo
uRelationLikeClass = BiClassInfo { className :: Name
className = ''URelationLike
, dataName :: Name
dataName = 'URelationship
, classToFun :: Name
classToFun = 'toURelation
, classFromFun :: Name
classFromFun = 'fromURelation
}
makeNodeLike :: HasCallStack => Name -> Q [Dec]
makeNodeLike :: HasCallStack => Name -> Q [Dec]
makeNodeLike Name
name = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
nodeLikeClass Name
name forall a. a -> a
id
makeNodeLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeNodeLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeNodeLikeWith = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
nodeLikeClass
makeURelationLike :: HasCallStack => Name -> Q [Dec]
makeURelationLike :: HasCallStack => Name -> Q [Dec]
makeURelationLike Name
name = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
uRelationLikeClass Name
name forall a. a -> a
id
makeURelationLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeURelationLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec]
makeURelationLikeWith = HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo
uRelationLikeClass
makeBiClassInstance :: HasCallStack => BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance :: HasCallStack =>
BiClassInfo -> Name -> (String -> String) -> Q [Dec]
makeBiClassInstance BiClassInfo {Name
classFromFun :: Name
classToFun :: Name
dataName :: Name
className :: Name
classFromFun :: BiClassInfo -> Name
classToFun :: BiClassInfo -> Name
dataName :: BiClassInfo -> Name
className :: BiClassInfo -> Name
..} Name
typeCon String -> String
fieldLabelModifier = do
TyConI Dec
declaration <- Name -> Q Info
reify Name
typeCon
let (Name
tyName, [Con]
constr) = HasCallStack => Dec -> (Name, [Con])
getTypeCons Dec
declaration
let label :: String
label = Name -> String
nameBase Name
tyName
let ([Name]
dataFields, [Type]
fieldTypes) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields) [Con]
constr
let (Name
consName, [(Name, Type)]
_) = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields [Con]
constr
Name
fresh <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
Clause
toClause <- String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause
makeToClause String
label Name
dataName Name
consName [Name]
dataFields String -> String
fieldLabelModifier
Clause
fromClause <- String
-> Name
-> Name
-> [Name]
-> [Type]
-> (String -> String)
-> Q Clause
makeFromClause String
label Name
consName Name
fresh [Name]
dataFields [Type]
fieldTypes String -> String
fieldLabelModifier
let bodyDecl :: [Dec]
bodyDecl = [Name -> [Clause] -> Dec
FunD Name
classToFun [Clause
toClause], Name -> [Clause] -> Dec
FunD Name
classFromFun [Clause
fromClause]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
className) (Name -> Type
ConT Name
typeCon)) [Dec]
bodyDecl]
getConsFields :: HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields :: HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields (RecC Name
cName [VarBangType]
decs) = (Name
cName, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
fname, Bang
_, Type
ftype) -> (Name
fname, Type
ftype)) [VarBangType]
decs)
getConsFields (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
cons) = HasCallStack => Con -> (Name, [(Name, Type)])
getConsFields Con
cons
getConsFields (RecGadtC (Name
cName:[Name]
_) [VarBangType]
decs Type
_) = (Name
cName, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
fname, Bang
_, Type
ftype) -> (Name
fname, Type
ftype)) [VarBangType]
decs)
getConsFields (NormalC Name
cName [BangType]
_) = (Name
cName, [])
getConsFields Con
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
"unsupported data declaration."
getTypeCons :: HasCallStack => Dec -> (Name, [Con])
getTypeCons :: HasCallStack => Dec -> (Name, [Con])
getTypeCons (DataD [Type]
_ Name
typeName [TyVarBndr ()]
_ Maybe Type
_ [Con]
constructors [DerivClause]
_) = (Name
typeName, [Con]
constructors)
getTypeCons (NewtypeD [Type]
_ Name
typeName [TyVarBndr ()]
_ Maybe Type
_ Con
constructor [DerivClause]
_) = (Name
typeName, [Con
constructor])
getTypeCons Dec
otherDecl = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
"unsupported declaration: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Dec
otherDecl forall a. [a] -> [a] -> [a]
++ String
"\nShould be either 'data' or 'newtype'."
makeToClause :: String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause
makeToClause :: String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause
makeToClause String
label Name
dataCons Name
consName [Name]
dataFields String -> String
fieldLabelModifier
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
dataFields = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ [Name] -> Exp
result []) []
| Bool
otherwise = do
[Name]
fieldVars <- forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequenceQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"_field" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Name]
dataFields
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [[Name] -> Pat
recPat [Name]
fieldVars] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ [Name] -> Exp
result [Name]
fieldVars) []
where
recPat :: [Name] -> Pat
recPat :: [Name] -> Pat
recPat [Name]
fieldVars = Pat -> Pat
ParensP forall a b. (a -> b) -> a -> b
$ Name -> [FieldPat] -> Pat
RecP Name
consName forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
dataFields forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fieldVars
valuesExp :: [Name] -> [Exp]
valuesExp :: [Name] -> [Exp]
valuesExp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'toValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE)
fieldNames :: [String]
fieldNames :: [String]
fieldNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> String
nameBase [Name]
dataFields
pairs :: [Name] -> [Exp]
pairs :: [Name] -> [Exp]
pairs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
fld Exp
val -> [Exp] -> Exp
tupE' [String -> Exp
strToTextE forall a b. (a -> b) -> a -> b
$ String -> String
fieldLabelModifier String
fld, Exp
val]) [String]
fieldNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [Exp]
valuesExp
mapE :: [Name] -> Exp
mapE :: [Name] -> Exp
mapE [Name]
vars = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fromList) ([Exp] -> Exp
ListE forall a b. (a -> b) -> a -> b
$ [Name] -> [Exp]
pairs [Name]
vars)
fieldFun :: Exp -> Exp
fieldFun :: Exp -> Exp
fieldFun | Name -> String
nameBase Name
dataCons forall a. Eq a => a -> a -> Bool
== String
"URelationship" = forall a. a -> a
id
| Name -> String
nameBase Name
dataCons forall a. Eq a => a -> a -> Bool
== String
"Node" = [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
| Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
"unsupported data type."
result :: [Name] -> Exp
result :: [Name] -> Exp
result = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
dataCons) (Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
dummyId)) (Exp -> Exp
fieldFun forall a b. (a -> b) -> a -> b
$ String -> Exp
strToTextE String
label)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Exp
mapE
makeFromClause :: String -> Name -> Name -> [Name] -> [Type] -> (String -> String) -> Q Clause
makeFromClause :: String
-> Name
-> Name
-> [Name]
-> [Type]
-> (String -> String)
-> Q Clause
makeFromClause String
label Name
conName Name
varName [Name]
dataFields [Type]
fieldTypes String -> String
fieldLabelModifier = do
let maybeFields :: [Bool]
maybeFields = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Bool
isMaybe [Type]
fieldTypes
let fieldNames :: [Text]
fieldNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
fieldLabelModifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
dataFields
let maybeNames :: [(Text, Bool)]
maybeNames = forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fieldNames [Bool]
maybeFields
let dataLabel :: Text
dataLabel = String -> Text
pack String
label
[Exp]
fieldNamesE <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Text
x -> [|x|]) [Text]
fieldNames
let maybeNamesE :: [Exp]
maybeNamesE = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp
n Bool
m -> [Exp] -> Exp
tupE' [Exp
n, Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ if Bool
m then Name
trueName else Name
falseName]) [Exp]
fieldNamesE [Bool]
maybeFields
let varExp :: Q Exp
varExp = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Exp
VarE Name
varName)
Guard
guardSuccess <- Exp -> Guard
NormalG forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|checkLabels $(varExp) [dataLabel] && checkProps $(varExp) maybeNames|]
Guard
guardFail <- Exp -> Guard
NormalG forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|otherwise|]
Exp
failExp <- [|unpackError $(varExp) (unpack dataLabel)|]
let successExp :: Exp
successExp = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
a Exp
f -> Exp -> Exp -> Exp
AppE Exp
a forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'getProp) (Name -> Exp
VarE Name
varName)) Exp
f) (Name -> Exp
ConE Name
conName) [Exp]
maybeNamesE
let successCase :: (Guard, Exp)
successCase = (Guard
guardSuccess, Exp
successExp)
let failCase :: (Guard, Exp)
failCase = (Guard
guardFail, Exp
failExp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
varName] ([(Guard, Exp)] -> Body
GuardedB [(Guard, Exp)
successCase, (Guard, Exp)
failCase]) []
isMaybe :: Type -> Bool
isMaybe :: Type -> Bool
isMaybe (AppT (ConT Name
t) Type
_) = Name
t forall a. Eq a => a -> a -> Bool
== ''Maybe
isMaybe Type
_ = Bool
False
strToTextE :: String -> Exp
strToTextE :: String -> Exp
strToTextE String
str = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pack) (Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ String
str)
checkProps :: Properties t => t -> [(Text, Bool)] -> Bool
checkProps :: forall t. Properties t => t -> [(Text, Bool)] -> Bool
checkProps t
container = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Text
fieldName, Bool
fieldMaybe) -> Bool
fieldMaybe Bool -> Bool -> Bool
|| Text
fieldName forall k a. Ord k => k -> Map k a -> Bool
`member` forall a. (Properties a, HasCallStack) => a -> Map Text Value
getProps t
container)
checkLabels :: Labels t => t -> [Text] -> Bool
checkLabels :: forall t. Labels t => t -> [Text] -> Bool
checkLabels t
container = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. (Labels a, HasCallStack) => a -> [Text]
getLabels t
container)
getProp :: (HasCallStack, Properties t, RecordValue a) => t -> (Text, Bool) -> a
getProp :: forall t a.
(HasCallStack, Properties t, RecordValue a) =>
t -> (Text, Bool) -> a
getProp t
container (Text
fieldName, Bool
fieldMaybe) | Bool
fieldMaybe Bool -> Bool -> Bool
&& Text
fieldName forall k a. Ord k => k -> Map k a -> Bool
`notMember` forall a. (Properties a, HasCallStack) => a -> Map Text Value
getProps t
container = forall {a}. RecordValue a => Value -> a
exactE forall a b. (a -> b) -> a -> b
$ () -> Value
N ()
| Bool
otherwise = forall {a}. RecordValue a => Value -> a
exactE (forall a. (Properties a, HasCallStack) => a -> Map Text Value
getProps t
container forall k a. Ord k => Map k a -> k -> a
! Text
fieldName)
where
exactE :: Value -> a
exactE Value
v = case forall a. RecordValue a => Value -> Either UnpackError a
exactEither Value
v of
Right a
res -> a
res
Left UnpackError
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnpackError
err
unpackError :: HasCallStack => Show c => c -> String -> a
unpackError :: forall c a. (HasCallStack, Show c) => c -> String -> a
unpackError c
container String
label = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ $String
currentLoc forall a. [a] -> [a] -> [a]
++ String
" could not unpack " forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
" from " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show c
container