diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bson-generic.cabal b/bson-generic.cabal new file mode 100644 --- /dev/null +++ b/bson-generic.cabal @@ -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: + diff --git a/src/Data/Bson/Generic.hs b/src/Data/Bson/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bson/Generic.hs @@ -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) + +------------------------------------------------------------------------------