bson-generic (empty) → 0.0.4
raw patch · 4 files changed
+272/−0 lines, 4 filesdep +basedep +bsondep +ghc-primsetup-changed
Dependencies added: base, bson, ghc-prim
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bson-generic.cabal +35/−0
- src/Data/Bson/Generic.hs +205/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Petr Pilař++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Petr Pilař nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bson-generic.cabal view
@@ -0,0 +1,35 @@+Name: bson-generic+Version: 0.0.4+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+License-file: LICENSE+Author: Petr Pilař+Maintainer: the.palmik+maintainer@gmail.com+Category: Data++Build-type: Simple++Cabal-version: >= 1.6++Source-repository head+ type: git+ location: git://github.com:Palmik/bson-generic.git++Library+ hs-source-dirs: src++ Exposed-modules:+ Data.Bson.Generic+ + Build-depends:+ base >= 4 && < 5,+ ghc-prim >= 0.2,+ bson >= 0.1.7 && < 0.2+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +
+ src/Data/Bson/Generic.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++------------------------------------------------------------------------------+-- | Examples+--+-- > data Test0 = A | B | C deriving (Generic, Typeable, Show, Eq)+-- > instance ToBSON Test0+-- > instance FromBSON Test0+-- >+-- > (fromBSON $ toBSON A) :: Maybe Test0+--+--+-- > data Test1 = Test1 String String deriving (Generic, Typeable, Show, Eq)+-- > instance ToBSON Test1+-- > instance FromBSON Test1+-- >+-- > (fromBSON $ toBSON $ Test1 "aa" "bb") :: Maybe Test1+--+--+-- > data Test2 = Test2 { test20 :: String, test21 :: String } deriving (Generic, Typeable, Show, Eq)+-- > instance ToBSON Test2+-- > instance FromBSON Test2+-- >+-- > (fromBSON $ toBSON $ Test2 "aa" "bb") :: Maybe Test2+--+--+-- > data Test3 = Test3 { test30 :: Test2, test31 :: String } deriving (Generic, Typeable, Show, Eq)+-- > instance ToBSON Test3+-- > instance FromBSON Test3+-- >+-- > (fromBSON $ toBSON $ Test3 (Test2 "aa" "bb") "cc") :: Maybe Test3+--+--+-- > data Test4 = Test4 { test4Key :: ObjectKey, test4 :: String } deriving (Generic, Typeable, Show, Eq)+-- > instance ToBSON Test4+-- > instance FromBSON Test4+-- >+-- > (fromBSON $ toBSON $ Test4 (ObjectKey . Just $ unsafePerformIO genObjectId) "something") :: Maybe Test4+-- > (fromBSON $ toBSON $ Test4 (ObjectKey Nothing) "something") :: Maybe Test4+--+--+-- > data Comment = Comment { author :: String, comments :: [Comment] } deriving (Generic, Typeable, Show, Eq)+-- > instance ToBSON Comment+-- > instance FromBSON Comment+-- >+-- > (fromBSON $ toBSON $ Comment "Joe1" [Comment "Joe2" [], Comment "Joe3" [Comment "Joe4" [], Comment "Joe5" []]]) :: Maybe Comment+--+--+-- Representation+--+-- > toBSON $ Test2 "aa" "bb"+-- >+-- > [ test20: "aa", test21: "bb" ]+--+-- > toBSON $ Test3 (Test2 "aa" "bb") "cc"+-- >+-- > [ test30: [ test20: "aa", test21: "bb"], test31: "cc" ]+--+-- > toBSON $ Test4 (ObjectKey . Just $ unsafePerformIO genObjectId) "something"+-- >+-- > [ _id: 4f226c27900faa06ab000001, test4: "something" ]+--+-- > toBSON $ Test4 (ObjectKey Nothing) "something"+-- >+-- > [ test4: "something" ]+--+-- > toBSON $ Comment "Joe1" [ Comment "Joe2" []+-- > , Comment "Joe3" [ Comment "Joe4" []+-- > , Comment "Joe5" []+-- > ]+-- > ]+-- >+-- > [ author: "Joe1", comments: [ [ author: "Joe2", comments: []]+-- > , [ author: "Joe3", comments: [ [ author: "Joe4", comments: []]+-- > , [ author: "Joe5", comments: []]+-- > ]]+-- > ]]+++module Data.Bson.Generic+( ToBSON(..)+, FromBSON(..)+, ObjectKey(..)+, keyLabel+) 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"++------------------------------------------------------------------------------++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, GenericToBSON (Rep a)) => a -> Document+ toBSON a = genericToBSON (from a)++class GenericToBSON f where+ genericToBSON :: f a -> Document++-- | Unit type -> Empty document+instance GenericToBSON U1 where+ genericToBSON U1 = []++-- | Sum of types+instance (GenericToBSON a, GenericToBSON b) => GenericToBSON (a :*: b) where+ genericToBSON (x :*: y) = genericToBSON x ++ genericToBSON y++-- | Product of types+instance (GenericToBSON a, GenericToBSON b) => GenericToBSON (a :+: b) where+ genericToBSON (L1 x) = genericToBSON x+ genericToBSON (R1 x) = genericToBSON x++-- | Datatype information tag+instance (GenericToBSON a) => GenericToBSON (D1 c a) where+ genericToBSON (M1 x) = genericToBSON x++-- | Constructor tag+instance (GenericToBSON a, Constructor c) => GenericToBSON (C1 c a) where+ genericToBSON c@(M1 x) = genericToBSON x++-- | Selector tag+instance (Val a, Selector s) => GenericToBSON (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 _ = []++-- | Constants+instance (ToBSON a) => GenericToBSON (K1 i a) where+ genericToBSON (K1 x) = toBSON x++------------------------------------------------------------------------------++------------------------------------------------------------------------------++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)++class GenericFromBSON f where+ genericFromBSON :: Document -> Maybe (f a)++instance GenericFromBSON U1 where+ genericFromBSON doc = Just U1++instance (GenericFromBSON a, GenericFromBSON b) => GenericFromBSON (a :*: b) where+ genericFromBSON doc = do+ x <- (genericFromBSON doc)+ y <- (genericFromBSON 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 (GenericFromBSON a, Constructor c) => GenericFromBSON (C1 c a) where+ genericFromBSON doc = maybe Nothing (Just . M1) (genericFromBSON doc)++instance (GenericFromBSON a) => GenericFromBSON (M1 D c a) where+ genericFromBSON doc = genericFromBSON doc >>= return . M1++instance (Val a, Selector s) => GenericFromBSON (S1 s (K1 i a)) where+ genericFromBSON 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)++------------------------------------------------------------------------------