packages feed

bson 0.2.4 → 0.3

raw patch · 4 files changed

+222/−53 lines, 4 filesdep ~QuickCheckdep ~test-frameworkdep ~test-framework-quickcheck2new-uploader

Dependency ranges changed: QuickCheck, test-framework, test-framework-quickcheck2

Files

Data/Bson.hs view
@@ -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
bson.cabal view
@@ -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 <knsd@knsd.net>+Maintainer:    Fedor Gogolev <knsd@knsd.net>, Greg Weber <greg@gregweber.info> 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
+ tests/Data/Bson/Binary/Tests.hs view
@@ -0,0 +1,8 @@+module Data.Bson.Binary.Tests+    ( tests+    ) where++import Test.Framework (Test, testGroup)++tests :: Test+tests = testGroup "Data.Bson.Binary.Tests" []
+ tests/Data/Bson/Tests.hs view
@@ -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)+    ]