Permalink
Browse files

Added lifters and improved the cabal file.

  • Loading branch information...
1 parent adc762e commit 853b3475dfabfab7429f9e225e094073ebad32f0 @gcross committed Dec 7, 2012
Showing with 122 additions and 7 deletions.
  1. +26 −5 AbortT-transformers.cabal
  2. +48 −1 Control/Monad/Trans/Abort.hs
  3. +2 −0 Setup.hs
  4. +46 −1 test.hs
View
@@ -1,20 +1,41 @@
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.6
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:
+ HUnit == 1.2.*,
+ QuickCheck >= 2.4 && < 2.6,
+ test-framework == 0.6.*,
+ test-framework-hunit == 0.2.*,
+ test-framework-quickcheck2 == 0.2.*
+
+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 @@ module Control.Monad.Trans.Abort (
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 @@ abort :: Monad m
-- 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
View
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
47 test.hs
@@ -3,10 +3,17 @@
import Control.Applicative
import Control.Monad.Trans.Class
-import Control.Monad.Trans.State
+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
@@ -75,4 +82,42 @@ main = defaultMain
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"))
+ )
+ ]
+ ]
]

0 comments on commit 853b347

Please sign in to comment.