diff --git a/AbortT-transformers.cabal b/AbortT-transformers.cabal --- a/AbortT-transformers.cabal +++ b/AbortT-transformers.cabal @@ -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 -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 diff --git a/Control/Monad/Trans/Abort.hs b/Control/Monad/Trans/Abort.hs --- a/Control/Monad/Trans/Abort.hs +++ b/Control/Monad/Trans/Abort.hs @@ -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 diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -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")) + ) + ] + ] + ]