Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Created repository for AbortT-transformers project.

  • Loading branch information...
commit 02946e0617809e945dba2d6303bbad5606a80c57 0 parents
Gregory Crosswhite authored
6 .gitignore
@@ -0,0 +1,6 @@
+dist
+*.hi
+*.o
+*~
+*#*
+test
18 AbortT-transformers.cabal
@@ -0,0 +1,18 @@
+Name: AbortT-transformers
+Version: 1.0
+License: BSD3
+License-file: LICENSE
+Author: Gregory Crosswhite
+Maintainer: Gregory Crosswhite <gcross@phys.washington.edu>
+Stability: Provisional
+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.
+Cabal-version: >=1.2.3
+Build-type: Simple
+Category: Control
+
+Library
+ Build-depends: base >= 3 && < 5,
+ transformers >= 0.2 && <0.3
+ Exposed-modules: Control.Monad.Trans.Abort
102 Control/Monad/Trans/Abort.hs
@@ -0,0 +1,102 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Trans.Abort
+-- Copyright : (c) Gregory Crosswhite 2010
+-- License : BSD3
+-- Maintainer : gcross@phys.washington.edu
+-- Stability : provisional
+-- Portability : portable
+--
+-- This module provides a monad and a monad transformer that allow the
+-- user to abort a monadic computation and immediately return a
+-- result.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Trans.Abort (
+ -- * The Abort monad
+ Abort,
+ runAbort,
+ -- * The AbortT monad transformer
+ AbortT(..),
+ runAbortT,
+ -- * Abort operations
+ abort
+ ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+
+import Data.Functor
+import Data.Functor.Identity
+
+-- ---------------------------------------------------------------------------
+-- | An abort monad, parametrized by the type @r@ of the value to return.
+type Abort r = AbortT r Identity
+
+-- | Execute the abort monad computation and return the resulting value.
+runAbort :: Abort r r -- ^ the monadic computation to run
+ -> r -- ^ the result of the computation
+runAbort = runIdentity . runAbortT
+
+-- ---------------------------------------------------------------------------
+-- | An abort monad transformer parametrized by
+--
+-- * @r@ - the value that will ultimately be returned; and
+--
+-- * @m@ - the inner monad.
+--
+-- The 'AbortT' type wraps a monadic value that is either
+--
+-- * 'Left' @r@, which indicates that the monadic computation has
+-- terminated with result @r@ and so all further steps in the computation
+-- should be ignored; or
+--
+-- * 'Right' @a@, which indicates that the computation is proceding normally
+-- and that its current value is @a@.
+newtype AbortT r m a = AbortT { unwrapAbortT :: m (Either r a) }
+
+instance Functor m => Functor (AbortT r m) where
+ fmap f = AbortT . fmap (either Left (Right . f)) . unwrapAbortT
+
+instance Applicative m => Applicative (AbortT r m) where
+ pure = AbortT . fmap Right . pure
+ (AbortT m) <*> (AbortT x) = AbortT ((fmap h m) <*> x)
+ where
+ h (Left g) = const (Left g)
+ h (Right f) = either Left (Right . f)
+
+instance Monad m => Monad (AbortT r m) where
+ return = AbortT . return . Right
+ (AbortT m) >>= f = AbortT $ m >>= either (return . Left) (unwrapAbortT . f)
+
+instance MonadIO m => MonadIO (AbortT r m) where
+ liftIO = lift . liftIO
+
+instance MonadTrans (AbortT r) where
+ lift = AbortT . (>>= return . Right)
+
+-- | Execute the abort monad computation and return the resulting
+-- (monadic) value.
+runAbortT :: Monad m
+ => AbortT r m r -- ^ the monadic computation to run
+ -> m r -- ^ the (monadic) result of the computation
+runAbortT (AbortT m) = m >>= either return return
+
+-- ---------------------------------------------------------------------------
+-- | Abort the computation and immediately return a result; all steps
+-- in the computation after this monadic computation will be ignored.
+--
+-- Note that since no further computation is performed after this, there is
+-- no way for subsequent computations to access the monadic value, and so it
+-- can be assigned an arbitrary type.
+abort :: Monad m
+ => r -- ^ the result to return
+ -> AbortT r m a -- ^ a monadic value that has the effect of
+ -- terminating the computation and immediately
+ -- returning a value; note that since all
+ -- subsequent steps in the computation will be
+ -- ignored, this monadic value can take an
+ -- arbitrary type since its value will never
+ -- be accessed
+abort = AbortT . return . Left
22 LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2010, Gregory Crosswhite
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
78 test.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnicodeSyntax #-}
+
+import Control.Applicative
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.State
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+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))
+ ]
+ ]
+ ]
Please sign in to comment.
Something went wrong with that request. Please try again.