module Data.Bson.Generic
( ToBSON(..)
, FromBSON(..)
, ObjectKey(..)
, genericToBSON
, genericFromBSON
, keyLabel
, constructorLabel
) where
import GHC.Generics
import qualified Data.Bson as BSON (lookup)
import Data.Bson
import Data.UString (u)
import Data.Typeable
import Control.Monad
keyLabel :: Label
keyLabel = u "_id"
constructorLabel :: Label
constructorLabel = u "_co"
newtype ObjectKey = ObjectKey { unObjectKey :: Maybe ObjectId } deriving (Generic, Typeable, Show, Eq)
instance FromBSON ObjectKey
instance ToBSON ObjectKey
instance (FromBSON a, ToBSON a, Typeable a, Show a, Eq a) => Val a where
val x = Doc $ toBSON x
cast' (Doc x) = fromBSON x
cast' _ = Nothing
class ToBSON a where
toBSON :: a -> Document
default toBSON :: (Generic a, GConstructorCount (Rep a), GToBSON (Rep a)) => a -> Document
toBSON val = genericToBSON (const Nothing) val
class FromBSON a where
fromBSON :: Document -> Maybe a
default fromBSON :: (Generic a, GConstructorCount (Rep a), GFromBSON (Rep a)) => Document -> Maybe a
fromBSON doc = genericFromBSON (const Nothing) doc
genericToBSON :: (Generic a, GConstructorCount (Rep a), GToBSON (Rep a))
=> (String -> Maybe String)
-> a
-> Document
genericToBSON tr val = gtoBSON tr (constructorCount val) (from val)
genericFromBSON :: forall a . (Generic a, GConstructorCount (Rep a), GFromBSON (Rep a))
=> (String -> Maybe String)
-> Document
-> Maybe a
genericFromBSON tr doc = maybe Nothing (Just . to) (gfromBSON tr (constructorCount (undefined :: a)) doc)
class GToBSON f where
gtoBSON :: (String -> Maybe String) -> Int -> f a -> Document
instance GToBSON U1 where
gtoBSON _ _ U1 = []
instance (GToBSON a, GToBSON b) => GToBSON (a :*: b) where
gtoBSON tr n (x :*: y) = gtoBSON tr n x ++ gtoBSON tr n y
instance (GToBSON a, GToBSON b) => GToBSON (a :+: b) where
gtoBSON tr n (L1 x) = gtoBSON tr n x
gtoBSON tr n (R1 x) = gtoBSON tr n x
instance (GToBSON a) => GToBSON (D1 c a) where
gtoBSON tr n (M1 x) = gtoBSON tr n x
instance (GToBSON a, Constructor c) => GToBSON (C1 c a) where
gtoBSON tr 0 (M1 x) = gtoBSON tr 0 x
gtoBSON tr 1 (M1 x) = gtoBSON tr 1 x
gtoBSON tr n c@(M1 x) = gtoBSON tr n x ++ [ constructorLabel =: conName c ]
instance (Val a, Selector s) => GToBSON (S1 s (K1 i a)) where
gtoBSON tr _ s@(M1 (K1 x)) = [sname =: x]
where sname = u $ maybe (selName s) id (tr $ selName s)
instance (Selector s) => GToBSON (S1 s (K1 i ObjectKey)) where
gtoBSON _ _ (M1 (K1 (ObjectKey (Just key)))) = [ keyLabel =: key ]
gtoBSON _ _ _ = []
instance (ToBSON a) => GToBSON (K1 i a) where
gtoBSON _ _ (K1 x) = toBSON x
class GFromBSON f where
gfromBSON :: (String -> Maybe String) -> Int -> Document -> Maybe (f a)
instance GFromBSON U1 where
gfromBSON _ _ doc = Just U1
instance (GFromBSON a, GFromBSON b) => GFromBSON (a :*: b) where
gfromBSON tr n doc = do
x <- (gfromBSON tr n doc)
y <- (gfromBSON tr n doc)
return (x :*: y)
instance (GFromBSON a, GFromBSON b) => GFromBSON (a :+: b) where
gfromBSON tr n doc = left `mplus` right
where left = maybe Nothing (Just . L1) (gfromBSON tr n doc)
right = maybe Nothing (Just . R1) (gfromBSON tr n doc)
instance (GFromBSON a, Constructor c) => GFromBSON (C1 c a) where
gfromBSON tr 0 doc = maybe Nothing (Just . M1) (gfromBSON tr 0 doc)
gfromBSON tr 1 doc = maybe Nothing (Just . M1) (gfromBSON tr 0 doc)
gfromBSON tr n doc = do
cname <- BSON.lookup constructorLabel doc
if (cname == (conName (undefined :: M1 C c a r)))
then maybe Nothing (Just . M1) (gfromBSON tr n doc)
else Nothing
instance (GFromBSON a) => GFromBSON (M1 D c a) where
gfromBSON tr n doc = gfromBSON tr n doc >>= return . M1
instance (Val a, Selector s) => GFromBSON (S1 s (K1 i a)) where
gfromBSON tr n doc = (BSON.lookup sname doc) >>= return . M1 . K1
where sname = u . maybe orig id $ tr orig
orig = (selName $ (undefined :: S1 s (K1 i a) r))
instance (Selector s) => GFromBSON (S1 s (K1 i ObjectKey)) where
gfromBSON _ n doc = Just . M1 . K1 $ ObjectKey (BSON.lookup keyLabel doc)
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