diff --git a/Data/Bson.hs b/Data/Bson.hs index f6b75c0..7f59b10 100644 --- a/Data/Bson.hs +++ b/Data/Bson.hs @@ -25,12 +25,12 @@ module Data.Bson ( ObjectId(..), timestamp, genObjectId, showHexLen ) where -import Prelude hiding (lookup) +import Prelude hiding (fail, lookup) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail (MonadFail) +#if MIN_VERSION_base(4, 9, 0) +import Control.Monad.Fail (MonadFail(fail)) #endif import Control.Monad (foldM) import Data.Bits (shift, (.|.)) diff --git a/tests/Data/Bson/Tests.hs b/tests/Data/Bson/Tests.hs index dc93a34..b52154b 100644 --- a/tests/Data/Bson/Tests.hs +++ b/tests/Data/Bson/Tests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-} module Data.Bson.Tests ( tests @@ -7,6 +7,9 @@ module Data.Bson.Tests #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail(MonadFail(..)) +#endif import Data.Int (Int32, Int64) import Data.Time.Calendar (Day(ModifiedJulianDay)) import Data.Time.Clock.POSIX (POSIXTime) @@ -16,7 +19,7 @@ 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 Test.QuickCheck (Arbitrary(..), elements, oneof, Property, (===)) import qualified Data.Text as T import Data.Bson (Val(cast', val), ObjectId(..), MinMaxKey(..), MongoStamp(..), @@ -106,6 +109,17 @@ testVal a = case cast' . val $ a of Nothing -> False Just a' -> a == a' +#if MIN_VERSION_base(4,9,0) +instance MonadFail (Either String) where + fail = Left + +testLookMonadFail :: Property +testLookMonadFail = + (Bson.look "key" [] :: Either String Value) + -- This is as opposed to an exception thrown from Prelude.fail: + === Left "expected \"key\" in []" +#endif + tests :: Test tests = testGroup "Data.Bson.Tests" [ testProperty "Val Bool" (testVal :: Bool -> Bool) @@ -131,4 +145,8 @@ tests = testGroup "Data.Bson.Tests" , testProperty "Val Binary" (testVal :: Binary -> Bool) -- , testProperty "Val Document" (testVal :: Document -> Bool) , testProperty "Val Text" (testVal :: Text -> Bool) + +#if MIN_VERSION_base(4,9,0) + , testProperty "'look' uses MonadFail.fail" testLookMonadFail +#endif ]