bson-generic 0.0.4 → 0.0.5

raw patch · 2 files changed

+77/−45 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• bson-generic.cabal +1/−1
• src/Data/Bson/Generic.hs +76/−44

@@ -1,5 +1,5 @@ Name:                bson-generic-Version:             0.0.4+Version:             0.0.5 Synopsis:            Generic functionality for BSON Description:         This package offers easy conversion from and to BSON data type for most of user defined data types. License:             BSD3

@@ -91,6 +91,7 @@ , FromBSON(..) , ObjectKey(..) , keyLabel+, constructorLabel ) where  import           GHC.Generics@@ -103,6 +104,29 @@ keyLabel :: Label keyLabel = u "_id" +constructorLabel :: Label+constructorLabel = u "_co"++class GConstructorCount f where+    gconstructorCount :: f a -> Int++instance GConstructorCount V1 where+    gconstructorCount _ = 0++instance (GConstructorCount a) => GConstructorCount (D1 d a) where+    gconstructorCount (M1 x) = gconstructorCount x++instance (Constructor c) => GConstructorCount (C1 c a) where+    gconstructorCount c = 1++instance (GConstructorCount a, GConstructorCount b) => GConstructorCount (a :+: b) where+    gconstructorCount (_ :: (a :+: b) r) = gconstructorCount (undefined :: a r) ++                                           gconstructorCount (undefined :: b r)++constructorCount :: (Generic a, GConstructorCount (Rep a)) => a -> Int+constructorCount x = gconstructorCount $ from x++ ------------------------------------------------------------------------------  newtype ObjectKey = ObjectKey { unObjectKey :: Maybe ObjectId } deriving (Generic, Typeable, Show, Eq)@@ -121,45 +145,47 @@ class ToBSON a where     toBSON :: a -> Document -    default toBSON :: (Generic a, GenericToBSON (Rep a)) => a -> Document-    toBSON a = genericToBSON (from a)+    default toBSON :: (Generic a, GConstructorCount (Rep a), GToBSON (Rep a)) => a -> Document+    toBSON a = genericToBSON (constructorCount a) (from a) -class GenericToBSON f where-    genericToBSON :: f a -> Document+class GToBSON f where+    genericToBSON :: Int -> f a -> Document  -- | Unit type -> Empty document-instance GenericToBSON U1 where-    genericToBSON U1 = []+instance GToBSON U1 where+    genericToBSON _ U1 = []  -- | Sum of types-instance (GenericToBSON a, GenericToBSON b) => GenericToBSON (a :*: b) where-    genericToBSON (x :*: y) = genericToBSON x ++ genericToBSON y+instance (GToBSON a, GToBSON b) => GToBSON (a :*: b) where+    genericToBSON n (x :*: y) = genericToBSON n x ++ genericToBSON n y  -- | Product of types-instance (GenericToBSON a, GenericToBSON b) => GenericToBSON (a :+: b) where-    genericToBSON (L1 x) = genericToBSON x-    genericToBSON (R1 x) = genericToBSON x+instance (GToBSON a, GToBSON b) => GToBSON (a :+: b) where+    genericToBSON n (L1 x) = genericToBSON n x+    genericToBSON n (R1 x) = genericToBSON n x  -- | Datatype information tag-instance (GenericToBSON a) => GenericToBSON (D1 c a) where-    genericToBSON (M1 x) = genericToBSON x+instance (GToBSON a) => GToBSON (D1 c a) where+    genericToBSON n (M1 x) = genericToBSON n x  -- | Constructor tag-instance (GenericToBSON a, Constructor c) => GenericToBSON (C1 c a) where-    genericToBSON c@(M1 x) = genericToBSON x+instance (GToBSON a, Constructor c) => GToBSON (C1 c a) where+    genericToBSON 0 (M1 x) = genericToBSON 0 x+    genericToBSON 1 (M1 x) = genericToBSON 1 x+    genericToBSON n c@(M1 x) = genericToBSON n x ++ [ constructorLabel =: conName c ]  -- | Selector tag-instance (Val a, Selector s) => GenericToBSON (S1 s (K1 i a)) where-    genericToBSON s@(M1 (K1 x)) = [u (selName s) =: x]+instance (Val a, Selector s) => GToBSON (S1 s (K1 i a)) where+    genericToBSON _ s@(M1 (K1 x)) = [u (selName s) =: x]  -- | ObjectKey special treatment-instance (Selector s) => GenericToBSON (S1 s (K1 i ObjectKey)) where-    genericToBSON (M1 (K1 (ObjectKey (Just key)))) = [ keyLabel =: key ]-    genericToBSON                                _ = []+instance (Selector s) => GToBSON (S1 s (K1 i ObjectKey)) where+    genericToBSON _ (M1 (K1 (ObjectKey (Just key)))) = [ keyLabel =: key ]+    genericToBSON                              _ _ = []  -- | Constants-instance (ToBSON a) => GenericToBSON (K1 i a) where-    genericToBSON (K1 x) = toBSON x+instance (ToBSON a) => GToBSON (K1 i a) where+    genericToBSON _ (K1 x) = toBSON x  ------------------------------------------------------------------------------ @@ -168,38 +194,44 @@ class FromBSON a where     fromBSON :: Document -> Maybe a -    default fromBSON :: (Generic a, GenericFromBSON (Rep a)) => Document -> Maybe a-    fromBSON doc = maybe Nothing (Just . to) (genericFromBSON doc)+    default fromBSON :: (Generic a, GConstructorCount (Rep a), GFromBSON (Rep a)) => Document -> Maybe a+    fromBSON doc = maybe Nothing (Just . to) (genericFromBSON (constructorCount (undefined :: a)) doc) -class GenericFromBSON f where-    genericFromBSON :: Document -> Maybe (f a)+class GFromBSON f where+    genericFromBSON :: Int -> Document -> Maybe (f a) -instance GenericFromBSON U1 where-    genericFromBSON doc = Just U1+instance GFromBSON U1 where+    genericFromBSON _ doc = Just U1 -instance (GenericFromBSON a, GenericFromBSON b) => GenericFromBSON (a :*: b) where-    genericFromBSON doc = do-        x <- (genericFromBSON doc)-        y <- (genericFromBSON doc)+instance (GFromBSON a, GFromBSON b) => GFromBSON (a :*: b) where+    genericFromBSON n doc = do+        x <- (genericFromBSON n doc)+        y <- (genericFromBSON n doc)         return (x :*: y) -instance (GenericFromBSON a, GenericFromBSON b) => GenericFromBSON (a :+: b) where-    genericFromBSON doc = left `mplus` right-        where left  = maybe Nothing (Just . L1) (genericFromBSON doc)-              right = maybe Nothing (Just . R1) (genericFromBSON doc)+instance (GFromBSON a, GFromBSON b) => GFromBSON (a :+: b) where+    genericFromBSON n doc = left `mplus` right+        where left  = maybe Nothing (Just . L1) (genericFromBSON n doc)+              right = maybe Nothing (Just . R1) (genericFromBSON n doc) -instance (GenericFromBSON a, Constructor c) => GenericFromBSON (C1 c a) where-    genericFromBSON doc = maybe Nothing (Just . M1) (genericFromBSON doc)+instance (GFromBSON a, Constructor c) => GFromBSON (C1 c a) where+    genericFromBSON 0 doc = maybe Nothing (Just . M1) (genericFromBSON 0 doc)+    genericFromBSON 1 doc = maybe Nothing (Just . M1) (genericFromBSON 0 doc)+    genericFromBSON n doc = do+        cname <- BSON.lookup constructorLabel doc+        if (cname == (conName (undefined :: M1 C c a r)))+           then maybe Nothing (Just . M1) (genericFromBSON n doc)+           else Nothing -instance (GenericFromBSON a) => GenericFromBSON (M1 D c a) where-    genericFromBSON doc = genericFromBSON doc >>= return . M1+instance (GFromBSON a) => GFromBSON (M1 D c a) where+    genericFromBSON n doc = genericFromBSON n doc >>= return . M1 -instance (Val a, Selector s) => GenericFromBSON (S1 s (K1 i a)) where-    genericFromBSON doc = (BSON.lookup sname doc) >>= return . M1 . K1+instance (Val a, Selector s) => GFromBSON (S1 s (K1 i a)) where+    genericFromBSON n doc = (BSON.lookup sname doc) >>= return . M1 . K1         where sname = u . selName $ (undefined :: S1 s (K1 i a) r)  -- | ObjectKey special treatment-instance (Selector s) => GenericFromBSON (S1 s (K1 i ObjectKey)) where-    genericFromBSON doc = Just . M1 . K1 $ ObjectKey (BSON.lookup keyLabel doc)+instance (Selector s) => GFromBSON (S1 s (K1 i ObjectKey)) where+    genericFromBSON n doc = Just . M1 . K1 $ ObjectKey (BSON.lookup keyLabel doc)  ------------------------------------------------------------------------------