bson-mapping 0.1 → 0.1.1

raw patch · 2 files changed

+29/−13 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• bson-mapping.cabal +1/−1
• src/Data/Bson/Mapping.hs +28/−12

@@ -1,5 +1,5 @@ Name:               bson-mapping-Version:            0.1+Version:            0.1.1 License:            OtherLicense License-File:       LICENSE Author:             Francesco Mazzoli <f@mazzo.li>

@@ -1,4 +1,4 @@-{-# Language TemplateHaskell #-}+{-# Language TemplateHaskell, FlexibleInstances, UndecidableInstances #-}  {- | @@ -35,34 +35,47 @@ >   print $ toBson post >   print $ $(selectFields ['time, 'content]) post +The 'deriveBson' function will also automatically derive a 'Val' instance+for the data type.+ -}  module Data.Bson.Mapping (     Bson (..)   , deriveBson     , selectFields+  , getLabel   ) where -import qualified Data.Bson as B+import Prelude hiding (lookup)++import Data.Bson+import Data.Data               (Data, Typeable)+ import Language.Haskell.TH import Language.Haskell.TH.Lift () -class Bson a where-  toBson   :: a -> B.Document-  fromBson :: Monad m => B.Document -> m a-+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 ''B.Val [varT key] | key <- keys ] ++ map return cx+  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        ]-  return [i]-+         +  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@@ -75,7 +88,7 @@     parseCon con = do       case con of         RecC name fields -> return (name, map (\(n, _, _) -> n) fields)-        _             -> inputError+        _                -> inputError          mkType con = foldl appT (conT con)     @@ -93,7 +106,7 @@     genStmts [] _ = return ([], [])     genStmts (f : fs) doc = do       fvar <- newName "f"-      let stmt = bindS (varP fvar) $ [| B.lookup (B.u (nameBase f)) $(varE doc) |]+      let stmt = bindS (varP fvar) $ [| lookup (u (nameBase f)) $(varE doc) |]       (fields, stmts) <- genStmts fs doc       return $ (return (f, VarE fvar) : fields, stmt : stmts)     @@ -104,4 +117,7 @@   lamE [varP d] (return e)   where     gf _ []        = [| [] |]-    gf d (n : ns') = [| (B.u (nameBase n) B.=: $(varE n) $(varE d)) : $(gf d ns') |]+    gf d (n : ns') = [| ($(getLabel n) =: $(varE n) $(varE d)) : $(gf d ns') |]++getLabel :: Name -> Q Exp+getLabel n = [| u (nameBase n) |]