module Data.Bson.Mapping (
Bson (..)
, deriveBson
, selectFields
, getLabel
) where
import Prelude hiding (lookup)
import Data.Bson
import Data.Data (Data, Typeable)
import Language.Haskell.TH
import Language.Haskell.TH.Lift ()
class (Show a, Eq a, Data a, Typeable a) => Bson a where
toBson :: a -> Document
fromBson :: Monad m => Document -> m a
deriveBson :: Name -> Q [Dec]
deriveBson type' = do
(cx, con, keys) <- bsonType
(constr, fields) <- parseCon con
let context = [ classP ''Val [varT key] | key <- keys ] ++ map return cx
i <- instanceD (sequence context) (mkType ''Bson [mkType type' (map varT keys)])
[ funD 'toBson [clause [] (normalB $ selectFields fields) []]
, deriveFromBson fields constr
]
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) |]) []]
]
return [i, i']
where
bsonType = do
info <- reify type'
case info of
TyConI (DataD cx _ keys [con] _) -> return (cx, con, map conv keys)
TyConI (NewtypeD cx _ keys con _) -> return (cx, con, map conv keys)
_ -> inputError
parseCon con = do
case con of
RecC name fields -> return (name, map (\(n, _, _) -> n) fields)
_ -> inputError
mkType con = foldl appT (conT con)
conv (PlainTV nm) = nm
conv (KindedTV nm _) = nm
inputError = error "deriveBson: Invalid type provided. The type must be a data with a single constructor or a newtype. The constructor must have named fields."
deriveFromBson fields constr = do
doc <- newName "doc"
(fields', stmts) <- genStmts fields doc
let ci = noBindS $ [| return $(recConE constr fields') |]
funD 'fromBson [clause [varP doc] (normalB $ doE (stmts ++ [ci])) []]
genStmts [] _ = return ([], [])
genStmts (f : fs) doc = do
fvar <- newName "f"
let stmt = bindS (varP fvar) $ [| lookup (u (nameBase f)) $(varE doc) |]
(fields, stmts) <- genStmts fs doc
return $ (return (f, VarE fvar) : fields, stmt : stmts)
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') |]
getLabel :: Name -> Q Exp
getLabel n = [| u (nameBase n) |]