module Database.MongoDB.Structured.Deriving.TH ( deriveStructured ) where
import Database.MongoDB.Structured.Query
import Database.MongoDB.Structured
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Char (toUpper)
import Data.Bson
import qualified Data.Bson as BSON
import Data.Functor ((<$>))
import Data.List (isPrefixOf)
data T1 = T1
data T2 = T2
data T3 = T3
deriveStructured :: Name -> Q [Dec]
deriveStructured t = do
let className = ''Structured
let collectionName = 'collection
let toBSONName = 'toBSON
let fromBSONName = 'fromBSON
TyConI (DataD _ _ _ (RecC conName fields:[]) _) <- getFields t
let fieldNames = map first fields
sObjIds = lookForSObjId fields
guardSObjId sObjIds
let sObjName = (first . head) sObjIds
collectionFunD <- funD_collection collectionName conName
toBSONFunD <- funD_toBSON toBSONName fieldNames sObjName
fromBSONFunD <- funD_fromBSON fromBSONName conName fieldNames sObjName
selTypesAndInst <- genSelectable t fields
let structuredInst = InstanceD [] (AppT (ConT className) (ConT t))
[ collectionFunD
, toBSONFunD
, fromBSONFunD ]
valInst <- gen_ValInstance t
return $ [structuredInst, valInst] ++ selTypesAndInst
where getFields t1 = do
r <- reify t1
case r of
TyConI (DataD _ _ _ (RecC _ _:[]) _) -> return ()
_ -> report True "Unsupported type. Can only derive for\
\ single-constructor record types."
return r
lookForSObjId = filter f
where f (_,_,(ConT n)) = (n == ''SObjId)
f _ = False
guardSObjId ids = if length ids /= 1
then report True "Expecting 1 SObjId field."
else return ()
first (a,_,_) = a
funD_toBSON :: Name
-> [Name]
-> Name
-> Q Dec
funD_toBSON toBSONName fieldNames sObjName = do
x <- newName "x"
toBSONBody <- NormalB <$> (gen_toBSON (varE x) fieldNames)
let toBSONClause = Clause [VarP x] (toBSONBody) []
return (FunD toBSONName [toBSONClause])
where gen_toBSON _ [] = [| [] |]
gen_toBSON x (f:fs) =
let l = nameBase f
i = nameBase sObjName
v = appE (varE f) x
in if l /= i
then [| ((u l) := val $v) : $(gen_toBSON x fs) |]
else [| let y = ((u "_id") := val (unSObjId $v))
ys = $(gen_toBSON x fs)
in if isNoSObjId $v
then ys
else y : ys
|]
funD_collection :: Name
-> Name
-> Q Dec
funD_collection collectionName conName = do
let n = nameBase conName
d <- [d| collectionName _ = (u n) |]
let [FunD _ cs] = d
return (FunD collectionName cs)
funD_fromBSON :: Name
-> Name
-> [Name]
-> Name
-> Q Dec
funD_fromBSON fromBSONName conName fieldNames sObjName = do
doc <- newName "doc"
fromBSONBody <- NormalB <$>
(gen_fromBSON conName fieldNames (varE doc) [] sObjName)
let fromBSONClause = Clause [VarP doc] (fromBSONBody) []
return (FunD fromBSONName [fromBSONClause])
lookup_m :: Val v => Label -> Document -> Maybe v
lookup_m = BSON.lookup
lookup_id :: Document -> Maybe SObjId
lookup_id d = Just (SObjId (lookup_m (u "_id") d :: Maybe ObjectId))
gen_fromBSON :: Name
-> [Name]
-> Q Exp
-> [(Name, Name)]
-> Name
-> Q Exp
gen_fromBSON conName [] _ vals _ = do
(AppE ret _ ) <- [| return () |]
let fExp = reverse $ map (\(l,v) -> (l, VarE v)) vals
return (AppE ret (RecConE conName fExp))
gen_fromBSON conName (l:ls) doc vals sObjName =
let lbl = nameBase l
in if lbl == (nameBase sObjName)
then [| lookup_id $doc >>= \v ->
$(gen_fromBSON conName ls doc ((l,'v):vals) sObjName) |]
else [| lookup_m (u lbl) $doc >>= \v ->
$(gen_fromBSON conName ls doc ((l,'v):vals) sObjName) |]
gen_ValInstance :: Name -> Q Dec
gen_ValInstance t = do
let valE = varE 'val
[InstanceD valCtx (AppT valCType _) decs] <-
[d| instance Val T1 where
val d = $valE (toBSON d)
cast' v = case v of
(Doc d) -> fromBSON d
_ -> error "Only Doc supported"
|]
let decs' = (fixNames 'cast') <$> ((fixNames 'val) <$> decs)
return (InstanceD valCtx (AppT valCType (ConT t)) decs')
where fixNames aN (FunD n cs) | (nameBase aN)
`isPrefixOf` (nameBase n) = FunD aN cs
fixNames _ x = x
genSelectable :: Name -> [VarStrictType] -> Q [Dec]
genSelectable conName vs = concat <$> (mapM (genSelectable' conName) vs)
genSelectable' :: Name -> VarStrictType -> Q [Dec]
genSelectable' conName (n,_,t) = do
let bn = mkName . cap $ nameBase n
sName = mkName "s"
[DataD _ _ _ _ derivs] <- [d| data Constr = Constr deriving (Eq, Show) |]
let dataType = DataD [] bn [] [NormalC bn []] derivs
[InstanceD selCtx (AppT (AppT (AppT selT _) _) _)
[FunD _ [Clause pats (NormalB (AppE varE_u _)) []]]]
<- [d| instance Selectable T1 T2 T3 where
s _ _ = (u "")
|]
let lit = LitE . StringL $ if is_id t then "_id" else nameBase n
selInstance =
InstanceD selCtx (AppT (AppT (AppT selT (ConT conName)) (ConT bn)) t)
[FunD sName
[Clause pats
(NormalB (AppE varE_u lit)) []
]
]
return [dataType, selInstance]
where cap (c:cs) = toUpper c : cs
cap x = x
is_id (ConT c) = (c == ''SObjId)
is_id _ = error "Invalid usage of is_id_, expecting ConT"