diff --git a/Data/Bson.hs b/Data/Bson.hs --- a/Data/Bson.hs +++ b/Data/Bson.hs @@ -4,10 +4,10 @@ -- Use the GHC language extension /OverloadedStrings/ to automatically convert -- String literals to Text -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable, RankNTypes, OverlappingInstances #-} -{-# LANGUAGE IncoherentInstances, ScopedTypeVariables #-} -{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} module Data.Bson ( -- * Document @@ -31,7 +31,7 @@ import Data.Int (Int32, Int64) import Data.IORef (IORef, newIORef, atomicModifyIORef) import Data.List (find, findIndex) -import Data.Maybe (maybeToList, mapMaybe) +import Data.Maybe (maybeToList, mapMaybe, fromMaybe) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds, getPOSIXTime) @@ -63,13 +63,13 @@ roundTo :: (RealFrac a) => a -> a -> a -- ^ Round second number to nearest multiple of first number. Eg: roundTo (1/1000) 0.12345 = 0.123 -roundTo mult n = fromIntegral (round (n / mult)) * mult +roundTo mult n = fromIntegral (round (n / mult) :: Integer) * mult showHexLen :: (Show n, Integral n) => Int -> n -> ShowS -- ^ showHex of n padded with leading zeros if necessary to fill d digits showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n where sigDigits 0 = 1 - sigDigits n' = truncate (logBase 16 $ fromIntegral n') + 1 + sigDigits n' = truncate (logBase 16 $ fromIntegral n' :: Double) + 1 -- * Document @@ -78,9 +78,9 @@ -- | Recursively lookup a nested field in a Document. (!?) :: Val a => Document -> Label -> Maybe a -doc !? label = foldM (flip lookup) doc (init chunks) >>= lookup (last chunks) +doc !? l = foldM (flip lookup) doc (init chunks) >>= lookup (last chunks) where - chunks = T.split (== '.') label + chunks = T.split (== '.') l look :: (Monad m) => Label -> Document -> m Value -- ^ Value of field in document, or fail (Nothing) if field not found @@ -95,10 +95,12 @@ -- ^ Value of field in document. Error if missing. valueAt k = runIdentity . look k -at :: forall v. (Val v) => Label -> Document -> v +at :: (Val v) => Label -> Document -> v -- ^ Typed value of field in document. Error if missing or wrong type. -at k doc = maybe err id (lookup k doc) where - err = error $ "expected (" ++ show k ++ " :: " ++ show (typeOf (undefined :: v)) ++ ") in " ++ show doc +at k doc = result + where + result = fromMaybe err (lookup k doc) + err = error $ "expected (" ++ show k ++ " :: " ++ show (typeOf result) ++ ") in " ++ show doc include :: [Label] -> Document -> Document -- ^ Only include fields of document in label list @@ -106,11 +108,11 @@ exclude :: [Label] -> Document -> Document -- ^ Exclude fields from document in label list -exclude keys doc = filter (\(k := _) -> notElem k keys) doc +exclude keys = filter (\(k := _) -> notElem k keys) merge :: Document -> Document -> Document -- ^ Merge documents with preference given to first one when both have the same label. I.e. for every (k := v) in first argument, if k exists in second argument then replace its value with v, otherwise add (k := v) to second argument. -merge es doc = foldl f doc es where +merge es docInitial = foldl f docInitial es where f doc (k := v) = case findIndex ((k ==) . label) doc of Nothing -> doc ++ [k := v] Just i -> let (x, _ : y) = splitAt i doc in x ++ [k := v] ++ y @@ -163,7 +165,7 @@ deriving (Typeable, Eq, Ord) instance Show Value where - showsPrec d v = fval (showsPrec d) v + showsPrec d = fval (showsPrec d) fval :: (forall a . (Val a) => a -> b) -> Value -> b -- ^ Apply generic function to typed value @@ -191,10 +193,14 @@ -- * Value conversion -cast :: forall m a. (Val a, Monad m) => Value -> m a +cast :: (Val a, Monad m) => Value -> m a -- ^ Convert Value to expected type, or fail (Nothing) if not of that type -cast v = maybe notType return (cast' v) where - notType = fail $ "expected " ++ show (typeOf (undefined :: a)) ++ ": " ++ show v +cast v = maybe notType return castingResult + where + castingResult = cast' v + unMaybe :: Maybe a -> a + unMaybe = undefined + notType = fail $ "expected " ++ show (typeOf $ unMaybe castingResult) ++ ": " ++ show v typed :: (Val a) => Value -> a -- ^ Convert Value to expected type. Error if not that type. @@ -208,9 +214,25 @@ -- | Haskell types of this class correspond to BSON value types class (Typeable a, Show a, Eq a) => Val a where + val :: a -> Value + + valList :: [a] -> Value + valList = Array . map val + + valMaybe :: Maybe a -> Value + valMaybe = maybe Null val + cast' :: Value -> Maybe a + cast'List :: Value -> Maybe [a] + cast'List (Array x) = mapM cast x + cast'List _ = Nothing + + cast'Maybe :: Value -> Maybe (Maybe a) + cast'Maybe Null = Just Nothing + cast'Maybe v = fmap Just (cast' v) + instance Val Double where val = Float cast' (Float x) = Just x @@ -231,26 +253,33 @@ cast' (Sym (Symbol x)) = Just x cast' _ = Nothing -instance Val String where - val = String . T.pack - cast' (String x) = Just $ T.unpack x - cast' (Sym (Symbol x)) = Just $ T.unpack x - cast' _ = Nothing +instance Val Char where + val x = valList [x] + valList = String . T.pack + cast' v = cast'List v >>= safeHead + where + safeHead list = case list of + x : _ -> Just x + _ -> Nothing + cast'List (String x) = Just $ T.unpack x + cast'List (Sym (Symbol x)) = Just $ T.unpack x + cast'List _ = Nothing -instance Val Document where - val = Doc - cast' (Doc x) = Just x +instance Val Field where + val x = valList [x] + valList = Doc cast' _ = Nothing + cast'List v = case v of + Doc x -> Just x + _ -> Nothing -instance Val [Value] where - val = Array - cast' (Array x) = Just x - cast' _ = Nothing +instance Val Value where + val = id + cast' = Just instance (Val a) => Val [a] where - val = Array . map val - cast' (Array x) = mapM cast x - cast' _ = Nothing + val = valList + cast' = cast'List instance Val Binary where val = Bin @@ -297,17 +326,9 @@ cast' (UTC x) = Just (utcTimeToPOSIXSeconds x) cast' _ = Nothing -instance Val (Maybe Value) where - val Nothing = Null - val (Just v) = v - cast' Null = Just Nothing - cast' v = Just (Just v) - instance (Val a) => Val (Maybe a) where - val Nothing = Null - val (Just a) = val a - cast' Null = Just Nothing - cast' v = fmap Just (cast' v) + val = valMaybe + cast' = cast'Maybe instance Val Regex where val = RegEx @@ -364,11 +385,14 @@ cast' (MinMax x) = Just x cast' _ = Nothing -fitInt :: forall n m. (Integral n, Integral m, Bounded m) => n -> Maybe m +fitInt :: (Integral n, Integral m, Bounded m) => n -> Maybe m -- ^ If number fits in type m then cast to m, otherwise Nothing -fitInt n = if fromIntegral (minBound :: m) <= n && n <= fromIntegral (maxBound :: m) - then Just (fromIntegral n) - else Nothing +fitInt n = + if fromIntegral (minBound `asTypeOf` result) <= n && n <= fromIntegral (maxBound `asTypeOf` result) + then Just result + else Nothing + where + result = fromIntegral n -- * Haskell types corresponding to special Bson value types diff --git a/bson.cabal b/bson.cabal --- a/bson.cabal +++ b/bson.cabal @@ -1,5 +1,5 @@ Name: bson -Version: 0.2.4 +Version: 0.3 Synopsis: BSON documents are JSON-like objects with a standard binary encoding. Description: A BSON Document is an untyped (dynamically type-checked) record. @@ -15,11 +15,11 @@ Category: Data Homepage: http://github.com/selectel/bson-haskell Author: Tony Hannan -Maintainer: Fedor Gogolev +Maintainer: Fedor Gogolev , Greg Weber Copyright: Copyright (c) 2010-2012 10gen Inc. License: OtherLicense License-file: LICENSE -Cabal-version: >= 1.8 +Cabal-version: >= 1.10 Build-type: Simple Library @@ -33,6 +33,9 @@ , network , text >= 0.11 + Default-Language: Haskell2010 + Default-Extensions: BangPatterns + Exposed-modules: Data.Bson, Data.Bson.Binary @@ -42,11 +45,13 @@ Type: exitcode-stdio-1.0 Hs-source-dirs: tests . Main-is: Tests.hs + Other-modules: Data.Bson.Binary.Tests + Data.Bson.Tests Ghc-options: -Wall -fno-warn-orphans - Build-depends: test-framework >= 0.4 && < 0.7 - , test-framework-quickcheck2 >= 0.2 && < 0.3 - , QuickCheck >= 2.4 && < 2.5 + Build-depends: test-framework >= 0.4 && < 0.9 + , test-framework-quickcheck2 >= 0.2 && < 0.4 + , QuickCheck >= 2.4 && < 2.8 -- Copied from regular dependencies... , base < 5 , time diff --git a/tests/Data/Bson/Binary/Tests.hs b/tests/Data/Bson/Binary/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Bson/Binary/Tests.hs @@ -0,0 +1,8 @@ +module Data.Bson.Binary.Tests + ( tests + ) where + +import Test.Framework (Test, testGroup) + +tests :: Test +tests = testGroup "Data.Bson.Binary.Tests" [] diff --git a/tests/Data/Bson/Tests.hs b/tests/Data/Bson/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Bson/Tests.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE TypeSynonymInstances #-} + +module Data.Bson.Tests + ( tests + ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Int (Int32, Int64) +import Data.Time.Calendar (Day(ModifiedJulianDay)) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Time.Clock (UTCTime(..), addUTCTime) +import qualified Data.ByteString as S + +import Data.Text (Text) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Arbitrary(..), elements, oneof) +import qualified Data.Text as T + +import Data.Bson (Val(cast', val), ObjectId(..), MinMaxKey(..), MongoStamp(..), + Symbol(..), Javascript(..), Regex(..), UserDefined(..), + MD5(..), UUID(..), Function(..), Binary(..), Field((:=)), + -- Document, + Value(..)) +import qualified Data.Bson as Bson + +instance Arbitrary S.ByteString where + arbitrary = S.pack <$> arbitrary + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary POSIXTime where + arbitrary = fromInteger <$> arbitrary + +instance Arbitrary UTCTime where + arbitrary = do + a <- arbitrary + b <- arbitrary + return $ addUTCTime (fromRational b) + $ UTCTime (ModifiedJulianDay a) 0 + +instance Arbitrary ObjectId where + arbitrary = Oid <$> arbitrary <*> arbitrary + +instance Arbitrary MinMaxKey where + arbitrary = elements [MinKey, MaxKey] + +instance Arbitrary MongoStamp where + arbitrary = MongoStamp <$> arbitrary + +instance Arbitrary Symbol where + arbitrary = Symbol <$> arbitrary + +instance Arbitrary Javascript where + arbitrary = Javascript <$> arbitrary <*> arbitrary + +instance Arbitrary Regex where + arbitrary = Regex <$> arbitrary <*> arbitrary + +instance Arbitrary UserDefined where + arbitrary = UserDefined <$> arbitrary + +instance Arbitrary MD5 where + arbitrary = MD5 <$> arbitrary + +instance Arbitrary UUID where + arbitrary = UUID <$> arbitrary + +instance Arbitrary Function where + arbitrary = Function <$> arbitrary + +instance Arbitrary Binary where + arbitrary = Binary <$> arbitrary + +instance Arbitrary Field where + arbitrary = (:=) <$> arbitrary <*> arbitrary + +instance Arbitrary Value where + arbitrary = oneof + [ Bson.Float <$> arbitrary + , Bson.String <$> arbitrary + , Bson.Doc <$> arbitrary + , Bson.Array <$> arbitrary + , Bson.Bin <$> arbitrary + , Bson.Fun <$> arbitrary + , Bson.Uuid <$> arbitrary + , Bson.Md5 <$> arbitrary + , Bson.UserDef <$> arbitrary + , Bson.ObjId <$> arbitrary + , Bson.UTC <$> arbitrary + , Bson.RegEx <$> arbitrary + , Bson.JavaScr <$> arbitrary + , Bson.Sym <$> arbitrary + , Bson.Int32 <$> arbitrary + , Bson.Int64 <$> arbitrary + , Bson.Stamp <$> arbitrary + , Bson.MinMax <$> arbitrary + , return Bson.Null + ] + +testVal :: Val a => a -> Bool +testVal a = case cast' . val $ a of + Nothing -> False + Just a' -> a == a' + +tests :: Test +tests = testGroup "Data.Bson.Tests" + [ testProperty "Val Bool" (testVal :: Bool -> Bool) + , testProperty "Val Double" (testVal :: Double -> Bool) + , testProperty "Val Float" (testVal :: Float -> Bool) + , testProperty "Val Int" (testVal :: Int -> Bool) + , testProperty "Val Int32" (testVal :: Int32 -> Bool) + , testProperty "Val Int64" (testVal :: Int64 -> Bool) + , testProperty "Val Integer" (testVal :: Integer -> Bool) + , testProperty "Val String" (testVal :: String -> Bool) + , testProperty "Val POSIXTime" (testVal :: POSIXTime -> Bool) + , testProperty "Val UTCTime" (testVal :: UTCTime -> Bool) + , testProperty "Val ObjectId" (testVal :: ObjectId -> Bool) + , testProperty "Val MinMaxKey" (testVal :: MinMaxKey -> Bool) + , testProperty "Val MongoStamp" (testVal :: MongoStamp -> Bool) + , testProperty "Val Symbol" (testVal :: Symbol -> Bool) + -- , testProperty "Val Javascript" (testVal :: Javascript -> Bool) + , testProperty "Val Regex" (testVal :: Regex -> Bool) + , testProperty "Val UserDefined" (testVal :: UserDefined -> Bool) + , testProperty "Val MD5" (testVal :: MD5 -> Bool) + , testProperty "Val UUID" (testVal :: UUID -> Bool) + , testProperty "Val Function" (testVal :: Function -> Bool) + , testProperty "Val Binary" (testVal :: Binary -> Bool) + -- , testProperty "Val Document" (testVal :: Document -> Bool) + , testProperty "Val Text" (testVal :: Text -> Bool) + ]