AbortT-transformers 1.0.0.1 → 1.0.1

raw patch · 3 files changed

+199/−6 lines, 3 filesdep +HUnitdep +QuickCheckdep +test-frameworkPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck2

API changes (from Hackage documentation)

Files

• AbortT-transformers.cabal +28/−5
• Control/Monad/Trans/Abort.hs +48/−1
• test.hs +123/−0

@@ -1,20 +1,43 @@ Name:                AbortT-transformers-Version:             1.0.0.1+Version:             1.0.1 License:             BSD3 License-file:        LICENSE Author:              Gregory Crosswhite Maintainer:          Gregory Crosswhite <gcrosswhite@gmail.com>-Stability:           Provisional+Stability:           Stable Homepage:            http://github.com/gcross/AbortT-transformers Synopsis:            A monad and monadic transformer providing "abort" functionality Description:         This module provides a monad and a monad transformer that allow the user to abort a monadic computation and immediately return a result.                      .-                     New in version 1.0.1: Bumped the transformers dependencies and updated the maintainer's e-mail address.-Cabal-version:       >=1.2.3+                     New in version 1.0.1: Added liftCallCC, liftCatch, liftListen, and liftPass, as well as more information to the cabal file.+                     .+                     New in version 1.0.0.1: Bumped the transformers dependencies and updated the maintainer's e-mail address.+Cabal-version:       >=1.8 Build-type:          Simple-Category:	     Control+Category:            Control  Library     Build-depends:   base >= 3 && < 5,                      transformers >= 0.2 && < 0.4     Exposed-modules: Control.Monad.Trans.Abort++Test-Suite test+    Type:       exitcode-stdio-1.0+    Main-is:    test.hs+    Build-depends:+        base >= 3 && < 5,+        HUnit == 1.2.*,+        QuickCheck >= 2.4 && < 2.6,+        test-framework == 0.6.*,+        test-framework-hunit == 0.2.*,+        test-framework-quickcheck2 == 0.2.*,+        transformers >= 0.2 && < 0.4++source-repository head+  type:                git+  location:            git://github.com/gcross/AbortT-transformers.git++source-repository this+  type:                git+  location:            git://github.com/gcross/AbortT-transformers.git+  tag:                 1.0.1

@@ -20,10 +20,16 @@     AbortT(..),     runAbortT,     -- * Abort operations-    abort+    abort,+    -- * lifters+    liftCallCC,+    liftCatch,+    liftListen,+    liftPass     ) where  import Control.Applicative+import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -100,3 +106,44 @@                       --   arbitrary type since its value will never                       --   be accessed abort = AbortT . return . Left++-- | Lifts a @callCC@ operation to 'AbortT'.+liftCallCC ::+       (((Either r a -> m (Either r b)) -> m (Either r a)) -> m (Either r a))+            -- ^ @callCC@ on the argument monad.+    -> ((a -> AbortT r m b) -> AbortT r m a)+            -- ^ 'AbortT' action that receives the continuation+    -> AbortT r m a+liftCallCC callCC f =+    AbortT . callCC $+        \c -> unwrapAbortT (f (AbortT . c . Right))++-- | Lift a @catchError@ operation to 'AbortT'.+liftCatch ::+      (m (Either r a) -> (e -> m (Either r a)) -> m (Either r a))+                                        -- ^ @catch@ on the argument monad.+    -> AbortT r m a                     -- ^ 'AbortT' action to attempt.+    -> (e -> AbortT r m a)              -- ^ Exception handler.+    -> AbortT r m a+liftCatch catch m handler =+    AbortT $ catch (unwrapAbortT m) (unwrapAbortT . handler)++-- | Lift a @listen@ operation to the new monad.+liftListen :: Monad m+    => (m (Either r a) -> m (Either r a,w)) -- ^ @listen@ on the argument monad.+    -> AbortT r m a                         -- ^ 'AbortT' action to run.+    -> AbortT r m (a,w)+liftListen listen = AbortT .+    (listen . unwrapAbortT >=> return . (\(a,w) -> either Left (\x -> Right (x,w)) a))++-- | Lift a @pass@ operation to the new monad.+liftPass :: Monad m+    => (m (Either r a,w -> w) -> m (Either r a)) -- ^ @pass@ on the argument monad.+    -> AbortT r m (a,w -> w)                     -- ^ 'AbortT' action to run.+    -> AbortT r m a+liftPass pass =+    AbortT . pass . liftM (+        either+          (\l -> (Left l,id))+          (\(r,f) -> (Right r,f))+    ) . unwrapAbortT

@@ -0,0 +1,123 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Error (ErrorT(..),catchError,throwError)+import Control.Monad.Trans.State (StateT(..),execState,modify)+import Control.Monad.Trans.Writer (WriterT(..),tell,listen,pass,runWriter)++import Data.Functor.Identity++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit+import Test.QuickCheck++import Control.Monad.Trans.Abort++main = defaultMain+    [testGroup "Functor"+        [testGroup "Identity"+            [testProperty "without Abort" $+                \(x :: Int) (y :: Int) → (== x+y) . runAbort . fmap (+y) . return $ x+            ,testProperty "with goto" $+                \(x :: Int) (y :: Int) → (== x) . runAbort . fmap (+y) . abort $ x+            ]+        ,testGroup "Maybe"+            [testProperty "without Abort" $+                \(x :: Int) (y :: Int) → (== Just (x+y)) . runAbortT . fmap (+y) . lift . Just $ x+            ,testProperty "with Abort" $+                \(x :: Int) (y :: Int) → (== Just x) . runAbortT . fmap (+y) . (>>= abort) . lift . Just $ x+            ]+        ]+    ,testGroup "Applicative"+        [testGroup "Identity"+            [testProperty "without Abort" $+                \(x :: Int) (y :: Int) → runAbort (return (+y) <*> return x) == x+y+            ,testProperty "with Abort" $+                \(x :: Int) (y :: Int) → runAbort (return (+y) <*> abort x) == x+            ]+        ]+    ,testGroup "Monad"+        [testGroup "Maybe"+            [testGroup "Just"+                [testProperty "without Abort" $+                    \(x :: Int) (y :: Int) → (== Just (x+y)) . runAbortT $ do+                        a ← lift (Just x)+                        b ← lift (Just y)+                        return (a+b)+                ,testProperty "with Abort" $+                    \(x :: Int) (y :: Int) → (== Just x) . runAbortT $ do+                        a ← lift (Just x)+                        abort a+                        b ← lift (Just y)+                        return (a+b)+                ]+            ,testGroup "Nothing"+                [testProperty "without Abort" $+                    \(x :: Int) (y :: Int) → (== Nothing) . runAbortT $ do+                        a ← lift (Just x)+                        b ← lift (Just y)+                        lift Nothing+                        return (a+b)+                ,testProperty "with Abort" $+                    \(x :: Int) (y :: Int) → (== Just x) . runAbortT $ do+                        a ← lift (Just x)+                        abort a+                        b ← lift (Just y)+                        lift Nothing+                        return (a+b)+                ]+            ]+        ,testGroup "State"+            [testProperty "without Abort" $+                \(x :: Int) (y :: Int) → (== x+y) . flip execState x . runAbortT $ do+                    lift (modify (+y))+            ,testProperty "with Abort" $+                \(x :: Int) (y :: Int) → (== x) . flip execState x . runAbortT $ do+                    abort ()+                    lift (modify (+y))+            ]+        ]+    ,testGroup "lifters"+        [testGroup "liftCallCC"+            [testCase "callCC bypasses abort" $+                True @=? (flip runCont id . runAbortT . liftCallCC callCC $ \c → (c True >> abort False))+            ,testCase "abort bypasses callCC" $+                True @=? (flip runCont id . runAbortT . liftCallCC callCC $ \c → (abort True >> c False))+            ]+        ,testGroup "liftCatch"+            [testCase "throwError bypasses abort" $+                Right True @=? (runIdentity . runErrorT . runAbortT $+                    liftCatch catchError+                        (lift (throwError "") >> abort False)+                        (\_ → return True)+                )+            ,testCase "abort bypasses throwError" $+                Right True @=? (runIdentity . runErrorT . runAbortT $+                    liftCatch catchError+                        (abort True >> lift (throwError ""))+                        (\_ → return False)+                )+            ]+        ,testGroup "liftListen"+            [testCase "abort before tell" $+                ((True,"right"),"") @=? (runWriter . runAbortT $ do+                    liftListen listen (abort (True,"right") >> lift (tell "wrong") >> return False)+                )+            ,testCase "abort after tell" $+                ((True,"A"),"B") @=? (runWriter . runAbortT $ do+                    liftListen listen (lift (tell "B") >> abort (True,"A") >> return False)+                )+            ]+        ,testGroup "liftPass"+            [testCase "abort bypasses function" $+                (True,"") @=? (runWriter . runAbortT $ do+                    liftPass pass (abort True >> return (False,const "wrong"))+                )+            ]+        ]+    ]