module Data.Bson.Mapping
( Bson (..)
, deriveBson
, selectFields
, getLabel
, getConsDoc
, subDocument
, getField
) where
import Prelude hiding (lookup)
import Data.Bson
import Data.Data (Typeable)
import Data.CompactString.UTF8 (append, cons)
import Language.Haskell.TH
import Language.Haskell.TH.Lift ()
class (Show a, Eq a, Typeable a) => Bson a where
toBson :: a -> Document
fromBson :: Monad m => Document -> m a
deriveBson :: Name -> Q [Dec]
deriveBson type' = do
(cx, conss, keys) <- bsonType
let context = [ classP ''Val [varT key] | key <- keys ] ++ map return cx
let fs = [ funD 'toBson (map deriveToBson conss)
, funD 'fromBson [clause [] (normalB $ deriveFromBson conss) []]
]
i <- instanceD (sequence context) (mkType ''Bson [mkType type' (map varT keys)]) fs
doc <- newName "doc"
i' <- instanceD (cxt []) (mkType ''Val [mkType type' (map varT keys)])
[ funD 'val [clause [] (normalB $ [| Doc . toBson |]) []]
, funD 'cast' [ clause [conP 'Doc [varP doc]] (normalB $ [| fromBson $(varE doc) |]) []
, clause [[p| _ |]] (normalB $ [| Nothing |]) []
]
]
return [i, i']
where
bsonType = do
info <- reify type'
case info of
TyConI (DataD cx _ keys conss _) -> return (cx, conss, map conv keys)
TyConI (NewtypeD cx _ keys con _) -> return (cx, [con], map conv keys)
_ -> inputError
mkType con = foldl appT (conT con)
conv (PlainTV n) = n
conv (KindedTV n _) = n
inputError = error $ "deriveBson: Invalid type provided. " ++
"The type must be a data type or a newtype. " ++
"Currently infix constructors and existential types are not supported."
deriveToBson :: Con -> Q Clause
deriveToBson (RecC name fields) = do
let fieldsDoc = selectFields $ map (\(n, _, _) -> n) fields
consDoc <- getConsDoc name
i <- newName "i"
clause [asP i (recP name [])] (normalB $ [| (merge $(getConsDoc name)) ($fieldsDoc $(varE i)) |]) []
deriveToBson (NormalC name types) = do
if null types
then clause [recP name []] (normalB $ getConsDoc name) []
else do
fields <- mapM (\_ -> newName "f") types
clause [conP name (map varP fields)]
(normalB $ [| (merge $(getConsDoc name)) . (\f -> [dataField =: f]) $ $(listE (map varE fields)) |]) []
deriveToBson _ = inputError
deriveFromBson :: [Con] -> Q Exp
deriveFromBson conss = do
con <- newName "con"
docN <- newName "doc"
(SigE _ (ConT strtype)) <- runQ [| "" :: String |]
let doc = varE docN
lamE [varP docN] $ doE
[ bindS (varP con) [| lookup consField $doc |]
, noBindS $ caseE (sigE (varE con) (conT strtype)) (map (genMatch doc) conss ++ noMatch)
]
noMatch = [match [p| _ |] (normalB [| fail "Couldn't find right constructor" |]) []]
genMatch :: Q Exp -> Con -> Q Match
genMatch doc (RecC name fields) =
flip (match (litP $ StringL $ nameBase name)) [] $ do
(fields', stmts) <- genStmts (map (\(n, _, _) -> n) fields) doc
let ci = noBindS $ [| return $(recConE name fields') |]
normalB (doE $ stmts ++ [ci])
genMatch doc (NormalC name types) =
flip (match (litP $ StringL $ nameBase name)) [] $
if null types
then normalB [| return $(conE name) |]
else do
data' <- newName "data"
let typesN = length types
types' <- mapM (\_ -> newName "t") types
let typesP = listP $ map varP types'
con = foldl (\e f -> (appE e (varE f))) (conE name) types'
normalB $ doE [ bindS (varP data') [| lookup dataField $doc |]
, noBindS [| if length $(varE data') /= $([| typesN |])
then fail "Wrong data for the constructor."
else $(doE [ letS [valD typesP (normalB $ varE data') []]
, noBindS [| return $con |]
])
|]
]
genMatch _ _ = inputError
genStmts :: [Name] -> Q Exp -> Q ([Q (Name, Exp)], [Q Stmt])
genStmts [] _ = return ([], [])
genStmts (f : fs) doc = do
fvar <- newName "f"
let stmt = bindS (varP fvar) $ [| lookup (u (nameBase f)) $doc |]
(fields, stmts) <- genStmts fs doc
return $ (return (f, VarE fvar) : fields, stmt : stmts)
dataField, consField :: UString
dataField = u "_data"
consField = u "_cons"
selectFields :: [Name] -> Q Exp
selectFields ns = do
d <- newName "d"
e <- gf d ns
lamE [varP d] (return e)
where
gf _ [] = [| [] |]
gf d (n : ns') = [| ($(getLabel n) =: $(varE n) $(varE d)) : $(gf d ns') |]
getConsDoc :: Name -> Q Exp
getConsDoc n = [| [consField =: nameBase n] |]
subDocument :: Label -> Document -> Document
subDocument lab doc = [append lab (cons '.' l) := v | (l := v) <- doc]
getLabel :: Name -> Q Exp
getLabel n = [| u (nameBase n) |]
getField :: Name -> Q Exp
getField n = [| \d -> $(getLabel n) =: $(varE n) d |]