bson-mapping 0.1.5.0 → 0.1.5.1
raw patch · 2 files changed
+25/−24 lines, 2 filesdep ~bsondep ~template-haskelldep ~text
Dependency ranges changed: bson, template-haskell, text
Files
- bson-mapping.cabal +4/−4
- src/Data/Bson/Mapping.hs +21/−20
bson-mapping.cabal view
@@ -1,5 +1,5 @@ Name: bson-mapping-Version: 0.1.5.0+Version: 0.1.5.1 License: OtherLicense License-File: LICENSE Author: Francesco Mazzoli <f@mazzo.li>@@ -19,10 +19,10 @@ Library Build-Depends: base >= 4 && < 5,- template-haskell >= 2.5,+ template-haskell >= 2.11.0.0, th-lift >= 0.5.3,- bson >= 0.2,- text >= 1.1+ bson >= 0.3,+ text == 1.2.* hs-source-dirs: src
src/Data/Bson/Mapping.hs view
@@ -1,4 +1,5 @@ {-# Language TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-} {- | @@ -17,7 +18,7 @@ > > data Post = Post { time :: UTCTime > , author :: String-> , content :: String +> , content :: String > , votes :: Int > } > deriving (Show, Read, Eq, Ord, Typeable)@@ -35,7 +36,7 @@ module Data.Bson.Mapping ( Bson (..)- , deriveBson + , deriveBson , selectFields , getLabel , getConsDoc@@ -47,7 +48,7 @@ import Data.Bson import Data.Data (Typeable)-import Data.Text (append, cons)+import Data.Text (Text, append, cons, pack) import Language.Haskell.TH import Language.Haskell.TH.Lift ()@@ -60,10 +61,10 @@ deriveBson :: Name -> Q [Dec] deriveBson type' = do (cx, conss, keys) <- bsonType- + -- Each type in the data type must be an instance of val let context = [ classP ''Val [varT key] | key <- keys ] ++ map return cx- + -- Generate the functions for the Bson instance let fs = [ funD 'toBson (map deriveToBson conss) , funD 'fromBson [clause [] (normalB $ deriveFromBson conss) []]@@ -72,36 +73,36 @@ -- Generate the Val instance (easy, since a Bson doc is -- automatically a Val)- doc <- newName "doc" + 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 -- Check that wha has been provided is a data/newtype declaration 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)+ 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 generates the clauses that pattern match the -- constructors of the data type, and then the function to convert -- them to Bson.@@ -141,13 +142,13 @@ deriveFromBson conss = do con <- newName "con" docN <- newName "doc"- (SigE _ (ConT strtype)) <- runQ [| "" :: String |]+ (SigE _ (ConT strtype)) <- runQ [| "" :: Text |] 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" |]) []] @@ -194,12 +195,12 @@ genStmts [] _ = return ([], []) genStmts (f : fs) doc = do fvar <- newName "f"- let stmt = bindS (varP fvar) $ [| lookup (nameBase f) $doc |]+ let stmt = bindS (varP fvar) $ [| lookup (pack (nameBase f)) $doc |] (fields, stmts) <- genStmts fs doc return $ (return (f, VarE fvar) : fields, stmt : stmts) -dataField, consField :: String+dataField, consField :: Text dataField = "_data" consField = "_cons" @@ -219,7 +220,7 @@ lamE [varP d] (return e) where gf _ [] = [| [] |]- gf d (n : ns') = [| ($(getLabel n) =: $(varE n) $(varE d)) : $(gf d ns') |]+ gf d (n : ns') = [| ((pack $(getLabel n)) =: $(varE n) $(varE d)) : $(gf d ns') |] {-|