packages feed

explicit-exception (empty) → 0.0.1

raw patch · 12 files changed

+1108/−0 lines, 12 filesdep +basedep +mtlsetup-changed

Dependencies added: base, mtl

Files

+ LICENSE view
@@ -0,0 +1,26 @@+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.++Neither the name of the <organization>; nor the names of its contributors+may be used to endorse or promote products derived from this software+without specific prior written permission.++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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ explicit-exception.cabal view
@@ -0,0 +1,60 @@+Name:             explicit-exception+Version:          0.0.1+License:          BSD3+License-File:     LICENSE+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+Homepage:         http://www.haskell.org/haskellwiki/Exception+Package-URL:      http://code.haskell.org/explicit-exception/+Category:         Control+Stability:        Experimental+Synopsis:         Exceptions which are explicit in the type signature.+Description:+   Synchronous and Asynchronous exceptions which are explicit in the type signature.+   The first ones are very similar to 'Either' and 'Control.Monad.Error.ErrorT'.+   The second ones are used for 'System.IO.readFile' and 'System.IO.hGetContents'.+   This package is a proposal for improved exception handling in Haskell.+   It strictly separates between handling of+   exceptional situations (file not found, invalid user input,+   see <http://www.haskell.org/haskellwiki/Exception>) and+   (programming) errors (division by zero, index out of range,+   see <http://www.haskell.org/haskellwiki/Error>).+   Handling of the first one is called \"exception handling\",+   whereas handling of errors is better known as \"debugging\".+   .+   For an application see the @midi@ package.+   .+   Although I'm not happy with the identifier style of the Monad Template Library+   (partially intended for unqualified use)+   I have tried to adopt it for this library,+   in order to let Haskell programmers get accustomed easily to it.+   .+   To do:+   Because many people requested it,+   we will provide a @bracket@ function that frees a resource+   both when an exception and an error occurs,+   that is, it combines exception handling and debugging.+   However note that freeing resources in case of an error is dangerous+   and may cause further damage.+Tested-With:       GHC==6.8.2+Cabal-Version:     >=1.2+Build-Type:        Simple++Library+  Build-Depends: base >= 2, mtl++  GHC-Options:      -Wall+  Hs-Source-Dirs:   src+  Exposed-Modules:+    Control.Monad.Exception.Asynchronous+    Control.Monad.Exception.Synchronous+  Other-Modules:+    Control.Monad.Exception.Warning+    Control.Monad.Exception.Label+    Control.Monad.Label+    System.IO.Straight+    System.IO.Exception.File+    System.IO.Exception.BinaryFile+    System.IO.Exception.TextFile+--    System.IO.Exception.Std+--    Debug.Error
+ src/Control/Monad/Exception/Asynchronous.hs view
@@ -0,0 +1,258 @@+{- |+Asynchronous exceptions can occur during the construction of a lazy data structure.+They are represent by a lazy data structure itself.+++TODO:++* Check whether laziness behaviour is reasonable.+-}+module Control.Monad.Exception.Asynchronous where++import qualified Control.Monad.Exception.Synchronous as Sync++import Control.Monad (mplus, liftM, )+import Control.Applicative (Applicative, liftA, )+{-+import Data.Traversable (Traversable, )+import Data.Foldable (Foldable, )+-}++import Prelude hiding (sequence)+++-- * Plain monad++{- |+Contains a value and a reason why the computation of the value of type @a@ was terminated.+Imagine @a@ as a list type, and an according operation like the 'readFile' operation.+If the exception part is 'Nothing' then the value could be constructed regularly.+If the exception part is 'Just' then the value could not be constructed completely.+However you can read the result of type @a@ lazily,+even if an exception occurs while it is evaluated.+If you evaluate the exception part,+then the result value is certainly computed completely.++However, we cannot provide functions+that combine several 'Exceptional' values,+due to the very different ways of combining the results of type @a@.+It is recommended to process the result value in an application specific way,+and after consumption of the result, throw a synchronous exception using 'toSynchronous'.+-}+data Exceptional e a =+   Exceptional {exception :: Maybe e, result :: a}+     deriving Show+++{- |+Create an exceptional value without exception.+-}+pure :: a -> Exceptional e a+pure = Exceptional Nothing++{- |+Create an exceptional value with exception.+-}+broken :: e -> a -> Exceptional e a+broken e = Exceptional (Just e)+++fromSynchronous :: a -> Sync.Exceptional e a -> Exceptional e a+fromSynchronous deflt x =+   force $ case x of+      Sync.Success y   -> Exceptional Nothing y+      Sync.Exception e -> Exceptional (Just e) deflt+++fromSynchronousNull :: Sync.Exceptional e () -> Exceptional e ()+fromSynchronousNull = fromSynchronous ()++toSynchronous :: Exceptional e a -> Sync.Exceptional e a+toSynchronous (Exceptional me a) =+   maybe (Sync.Success a) Sync.Exception me+++throw :: e -> Exceptional e ()+throw e = Exceptional (Just e) ()++++{- |+Repeat an action with synchronous exceptions until an exception occurs.+Combine all atomic results using the @bind@ function.+It may be @cons = (:)@ and @empty = []@ for @b@ being a list type.+The @defer@ function may be @id@+or @unsafeInterleaveIO@ for lazy read operations.+The exception is returned as asynchronous exception.+-}+manySynchronousT :: (Monad m) =>+   (m (Exceptional e b) -> m (Exceptional e b))+                           {- ^ @defer@ function -} ->+   (a -> b -> b)           {- ^ @cons@ function -} ->+   b                       {- ^ @empty@ -} ->+   Sync.ExceptionalT e m a {- ^ atomic action to repeat -} ->+   m (Exceptional e b)+manySynchronousT defer cons empty action =+   let recurse =+          liftM force $ defer $+          do r <- Sync.tryT action+             case r of+                Sync.Exception e -> return (Exceptional (Just e) empty)+                Sync.Success x   -> liftM (fmap (cons x)) recurse+   in  recurse++{- |+Scan @x@ using the @decons@ function+and run an action with synchronous exceptions for each element fetched from @x@.+Each invocation of an element action may stop this function+due to an exception.+If all element action can be performed successfully+and if there is an asynchronous exception+then at the end this exception is raised as synchronous exception.+@decons@ function might be @viewL@.+-}+processToSynchronousT_ :: (Monad m) =>+   (b -> Maybe (a,b))  {- ^ decons function -} ->+   (a -> Sync.ExceptionalT e m ())+                       {- ^ action that is run for each element fetched from @x@ -} ->+   Exceptional e b     {- ^ value @x@ of type @b@ with asynchronous exception -} ->+   Sync.ExceptionalT e m ()+processToSynchronousT_ decons action (Exceptional me x) =+   let recurse b0 =+          maybe+             (maybe (return ()) Sync.throwT me)+             (\(a,b1) -> action a >> recurse b1)+             (decons b0)+   in  recurse x+++-- ** handling of special result types++{- |+This is an example for application specific handling of result values.+Assume you obtain two lazy lists say from 'readFile'+and you want to zip their contents.+If one of the stream readers emits an exception,+we quit with that exception.+If both streams have throw an exception at the same file position,+the exception of the first stream is propagated.+-}+zipWith ::+   (a -> b -> c) ->+   Exceptional e [a] -> Exceptional e [b] -> Exceptional e [c]+zipWith f (Exceptional ea a0) (Exceptional eb b0) =+   let recurse (a:as) (b:bs) =+          fmap (f a b :) (recurseF as bs)+       recurse as _ =+          Exceptional (case as of [] -> mplus ea eb; _ -> eb) []+       recurseF as bs = force $ recurse as bs+   in  recurseF a0 b0+++{- | construct Exceptional constructor lazily -}+force :: Exceptional e a -> Exceptional e a+force (~(Exceptional e a)) = Exceptional e a+++{-+catch :: Exceptional e0 a -> (e0 -> Exceptional e1 a) -> Exceptional e1 a+catch x handler =+   case x of+      Success a   -> Success a+      Exception e -> handler e+-}++instance Functor (Exceptional e) where+   fmap f x =+      case x of+         ~(Exceptional e a) -> Exceptional e (f a)++{-+Foldable instance would allow to strip off the exception too easily.++instance Foldable (Exceptional e) where+++I like the methods of traversable, but Traversable instance requires Foldable instance++instance Traversable (Exceptional e) where+-}++{-# INLINE traverse #-}+traverse :: Applicative f => (a -> f b) -> Exceptional e a -> f (Exceptional e b)+traverse f = sequenceA . fmap f++{-# INLINE sequenceA #-}+sequenceA :: Applicative f => Exceptional e (f a) -> f (Exceptional e a)+sequenceA ~(Exceptional e a) =+   liftA (Exceptional e) a++{-# INLINE mapM #-}+mapM :: Monad m => (a -> m b) -> Exceptional e a -> m (Exceptional e b)+mapM f = sequence . fmap f++{-# INLINE sequence #-}+sequence :: Monad m => Exceptional e (m a) -> m (Exceptional e a)+sequence ~(Exceptional e a) =+   liftM (Exceptional e) a++++{-+instance Applicative (Exceptional e) where+   pure = Exceptional [] -- [Nothing]?+   f <*> x =+      case f of+         Exceptional e0 g ->+            case x of+               Exceptional e1 y -> Exceptional (mplus e0 e1) (g y)++instance Monad (Exceptional e) where+   return = Exceptional [] -- [Nothing]?+   fail _msg =+      Exceptional+         [Just (error "Asynchronous.fail exception")]+         (error "Asynchronous.fail result")+   x >>= f =+      case x of+         Exceptional e0 y ->+            case f y of+               Exceptional e1 z -> Exceptional (e0 ++ e1) z+++-- * Monad transformer++newtype ExceptionalT e m a =+   ExceptionalT {runExceptionalT :: m (Exceptional e a)}+++fromSynchronousT :: Functor m =>+   a -> Sync.ExceptionalT e m a -> ExceptionalT e m a+fromSynchronousT deflt (Sync.ExceptionalT mx) =+   ExceptionalT $ fmap (fromSynchronous deflt) mx++++throwT :: (Monad m) =>+   e -> ExceptionalT e m ()+throwT = ExceptionalT . return . throw++++instance Functor m => Functor (ExceptionalT e m) where+   fmap f (ExceptionalT x) =+      ExceptionalT (fmap (fmap f) x)++instance Applicative m => Applicative (ExceptionalT e m) where+   pure = ExceptionalT . pure . pure+   ExceptionalT f <*> ExceptionalT x =+      ExceptionalT (fmap (<*>) f <*> x)++instance Monad m => Monad (ExceptionalT e m) where+   return = ExceptionalT . return . return+   x0 >>= f =+      ExceptionalT $+      do Exceptional ex x <- runExceptionalT x0+         Exceptional ey y <- runExceptionalT (f x)+         return $ Exceptional (ex ++ ey) y+-}
+ src/Control/Monad/Exception/Label.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{- |+Here we implement a monad transformer+which adds exception handling and+labelling of actions (using "Control.Monad.Label")+in order to extend exceptions with a kind of call stack.+-}+module Control.Monad.Exception.Label where++import qualified Control.Monad.Exception.Synchronous as Exception+import qualified Control.Monad.Label as Label++import Control.Monad.Exception.Synchronous (ExceptionalT, mapExceptionT, )+import Control.Monad.Label (LabelT, )++import Control.Monad (liftM, )+import Control.Monad.Fix (MonadFix, )+import Control.Monad.Trans (MonadTrans, lift, )+++data LabeledException l e =+   LabeledException {labels :: [l], exception :: e}++newtype LabeledExceptionalT l e m a =+   LabeledExceptionalT+      {runLabeledExceptionalT :: LabelT l (ExceptionalT (LabeledException l e) m) a}+      deriving (Monad, MonadFix)+++runLabelT :: (Monad m) =>+   LabeledExceptionalT l e m a ->+   [l] ->+   ExceptionalT (LabeledException l e) m a+runLabelT =+   Label.runLabelT . runLabeledExceptionalT++labelT :: (Monad m) =>+   ExceptionalT (LabeledException l e) m a ->+   LabeledExceptionalT l e m a+labelT =+   LabeledExceptionalT . lift -- Label.LabelT . ReaderT+++stripLabelT :: (Monad m) =>+   LabeledExceptionalT l e m a -> ExceptionalT e m a+stripLabelT action =+   mapExceptionT exception (runLabelT action [])++decorateLabelT :: (Monad m) =>+   ExceptionalT e m a -> LabeledExceptionalT l e m a+decorateLabelT =+   labelT . mapExceptionT (LabeledException [])++getLabels :: (Monad m) =>+   LabeledExceptionalT l e m [l]+getLabels = LabeledExceptionalT $ Label.askT+++throwT :: (Monad m) =>+   e -> LabeledExceptionalT l e m a+throwT e =+   do l <- getLabels+      labelT $ Exception.throwT (LabeledException l e)+++{- |+Currently 'catchT' calls the exception handler with a full call stack.+Since 'catchT' handles exceptions locally+it may however clear the call stack before calling the inner action+and a re-throw should append the inner call stack to the outer one.+For this semantics, a difference list would be more efficient for labels.+-}+catchT :: (Monad m) =>+   LabeledExceptionalT l e0 m a ->+   ([l] -> e0 -> LabeledExceptionalT l e1 m a) ->+   LabeledExceptionalT l e1 m a+catchT action handler =+   do ls <- getLabels+      labelT $ Exception.catchT+         (runLabelT action ls)+         (\(LabeledException l e) -> runLabelT (handler l e) ls)+++{- |+If the enclosed monad has custom exception facilities,+they could skip the cleanup code.+Make sure, that this cannot happen by choosing an appropriate monad.+-}+bracketT :: (Monad m) =>+   l ->+   LabeledExceptionalT l e m h ->+   (h -> LabeledExceptionalT l e m ()) ->+   (h -> LabeledExceptionalT l e m a) ->+   LabeledExceptionalT l e m a+bracketT label open close action =+   do ls <- liftM (label:) getLabels+      labelT $+         Exception.bracketT+            (runLabelT open ls)+            (\h -> runLabelT (close h) ls)+            (\h -> runLabelT (action h) ls)+++instance MonadTrans (LabeledExceptionalT l e) where+   lift m = labelT $ lift m
+ src/Control/Monad/Exception/Synchronous.hs view
@@ -0,0 +1,245 @@+{- |+Synchronous exceptions immediately abort a series of computations.+We provide monads for describing this behaviour.+-}+module Control.Monad.Exception.Synchronous where++import Control.Applicative (Applicative(pure, (<*>)))+import Control.Monad (liftM, )+import Control.Monad.Fix (MonadFix, mfix, )+import Control.Monad.Trans (MonadTrans, lift, )+import Control.Monad.Error (ErrorT(ErrorT, runErrorT))++import Prelude hiding (catch, )+++-- * Plain monad++{- |+Like 'Either', but explicitly intended for handling of exceptional results.+In contrast to 'Either' we do not support 'fail'.+Calling 'fail' in the 'Exceptional' monad is an error.+-}+data Exceptional e a =+     Success a+   | Exception e+   deriving (Show, Eq)+++fromMaybe :: e -> Maybe a -> Exceptional e a+fromMaybe e = maybe (Exception e) Success++fromEither :: Either e a -> Exceptional e a+fromEither = either Exception Success++toEither :: Exceptional e a -> Either e a+toEither x =+   case x of+      Success a   -> Right a+      Exception e -> Left e++{- |+If you are sure that the value is always a 'Success'+you can tell that the run-time system+thus making your program lazy.+However, try to avoid this function by using 'catch' and friends,+since this function is partial.+-}+force :: Exceptional e a -> Exceptional e a+force ~(Success a) = Success a++mapException :: (e0 -> e1) -> Exceptional e0 a -> Exceptional e1 a+mapException f x =+   case x of+      Success a   -> Success a+      Exception e -> Exception (f e)++mapExceptional :: (e0 -> e1) -> (a -> b) -> Exceptional e0 a -> Exceptional e1 b+mapExceptional f g x =+   case x of+      Success a   -> Success (g a)+      Exception e -> Exception (f e)++throw :: e -> Exceptional e a+throw = Exception++catch :: Exceptional e0 a -> (e0 -> Exceptional e1 a) -> Exceptional e1 a+catch x handler =+   case x of+      Success a   -> Success a+      Exception e -> handler e++{-+bracket ::+   Exceptional e h ->+   (h -> Exceptional e ()) ->+   (h -> Exceptional e a) ->+   Exceptional e a+bracket open close action =+   open >>= \h ->+   case action h of+-}++resolve :: (e -> a) -> Exceptional e a -> a+resolve handler x =+   case x of+      Success a   -> a+      Exception e -> handler e+++instance Functor (Exceptional e) where+   fmap f x =+      case x of+         Success a   -> Success (f a)+         Exception e -> Exception e++instance Applicative (Exceptional e) where+   pure = Success+   f <*> x =+      case f of+         Exception e -> Exception e+         Success g ->+            case x of+               Success a   -> Success (g a)+               Exception e -> Exception e++instance Monad (Exceptional e) where+   return = Success+   fail _msg = Exception (error "Exception.Synchronous: Monad.fail method is not supported")+   x >>= f =+      case x of+         Exception e -> Exception e+         Success y -> f y++instance MonadFix (Exceptional e) where+    mfix f =+       let unSuccess ~(Success x) = x+           a = f (unSuccess a)+       in  a++++-- * Monad transformer++-- | like ErrorT, but ExceptionalT is the better name in order to distinguish from real (programming) errors+newtype ExceptionalT e m a =+   ExceptionalT {runExceptionalT :: m (Exceptional e a)}+++fromErrorT :: Monad m => ErrorT e m a -> ExceptionalT e m a+fromErrorT  =  ExceptionalT . liftM fromEither . runErrorT++toErrorT :: Monad m => ExceptionalT e m a -> ErrorT e m a+toErrorT  =  ErrorT . liftM toEither . runExceptionalT++{- |+see 'force'+-}+forceT :: Monad m => ExceptionalT e m a -> ExceptionalT e m a+forceT =+   ExceptionalT . liftM force . runExceptionalT+++mapExceptionT :: (Monad m) =>+   (e0 -> e1) ->+   ExceptionalT e0 m a ->+   ExceptionalT e1 m a+mapExceptionT f =+   ExceptionalT . liftM (mapException f) . runExceptionalT++mapExceptionalT ::+   (m (Exceptional e0 a) -> n (Exceptional e1 b)) ->+   ExceptionalT e0 m a -> ExceptionalT e1 n b+mapExceptionalT f =+   ExceptionalT . f . runExceptionalT++throwT :: (Monad m) =>+   e -> ExceptionalT e m a+throwT = ExceptionalT . return . throw++catchT :: (Monad m) =>+   ExceptionalT e0 m a ->+   (e0 -> ExceptionalT e1 m a) ->+   ExceptionalT e1 m a+catchT action handler =+   ExceptionalT $+   runExceptionalT action >>= \x ->+      case x of+         Success a   -> return $ Success a+         Exception e -> runExceptionalT $ handler e++{- |+If the enclosed monad has custom exception facilities,+they could skip the cleanup code.+Make sure, that this cannot happen by choosing an appropriate monad.+-}+bracketT :: (Monad m) =>+   ExceptionalT e m h ->+   (h -> ExceptionalT e m ()) ->+   (h -> ExceptionalT e m a) ->+   ExceptionalT e m a+bracketT open close action =+   open >>= \h ->+      ExceptionalT $+         do a <- runExceptionalT (action h)+            c <- runExceptionalT (close h)+            return (a >>= \r -> c >> return r)++resolveT :: (Monad m) =>+   (e -> m a) -> ExceptionalT e m a -> m a+resolveT handler x =+   do r <- runExceptionalT x+      resolve handler (fmap return r)++tryT :: (Monad m) =>+   ExceptionalT e m a -> m (Exceptional e a)+tryT = runExceptionalT+++{- |+Repeat an action until an exception occurs.+Initialize the result with @empty@ and add new elements using @cons@+(e.g. @[]@ and @(:)@).+The exception handler decides whether the terminating exception+is re-raised ('Just') or catched ('Nothing').+-}+manyT :: (Monad m) =>+   (e0 -> Maybe e1)        {- ^ exception handler -} ->+   (a -> b -> b)           {- ^ @cons@ function -} ->+   b                       {- ^ @empty@ -} ->+   ExceptionalT e0 m a     {- ^ atomic action to repeat -} ->+   ExceptionalT e1 m b+manyT handler cons empty action =+   let recurse =+          do r <- lift $ tryT action+             case r of+                Exception e -> maybe (return empty) throwT (handler e)+                Success x   -> liftM (cons x) recurse+   in  recurse+++++instance Functor m => Functor (ExceptionalT e m) where+   fmap f (ExceptionalT x) =+      ExceptionalT (fmap (fmap f) x)++instance Applicative m => Applicative (ExceptionalT e m) where+   pure = ExceptionalT . pure . pure+   ExceptionalT f <*> ExceptionalT x =+      ExceptionalT (fmap (<*>) f <*> x)++instance Monad m => Monad (ExceptionalT e m) where+   return = ExceptionalT . return . return+   x0 >>= f =+      ExceptionalT $+         runExceptionalT x0 >>= \x1 ->+         case x1 of+            Exception e -> return (Exception e)+            Success x -> runExceptionalT $ f x++instance (MonadFix m) => MonadFix (ExceptionalT e m) where+   mfix f = ExceptionalT $ mfix $ \(Success r) -> runExceptionalT $ f r++instance MonadTrans (ExceptionalT e) where+   lift m = ExceptionalT $ liftM Success m
+ src/Control/Monad/Exception/Warning.hs view
@@ -0,0 +1,123 @@+{- |+This module is currently not in use and may be considered a design study.+Warning monad is like 'Control.Monad.Writer.Writer' monad,+it can be used to record exceptions that do not break program flow.++TODO:++* Better name for 'Warnable'+-}+module Control.Monad.Exception.Warning where++import qualified Control.Monad.Exception.Synchronous as Sync++import Control.Applicative (Applicative(pure, (<*>)))+import Control.Monad (mplus)+import Data.Maybe (catMaybes)+++-- * Plain monad++{- |+Contains a value and+possibly warnings that were generated while the computation of that value.+-}+data Warnable e a =+   Warnable [Maybe e] a+++{- |+Convert an exception to a warning.+-}+fromException :: a -> Sync.Exceptional e a -> Warnable e a+fromException deflt x =+{- Here the list item can only be constructed after the constructor of x is known+   case x of+      Sync.Success y   -> Warnable [Nothing] y+      Sync.Exception e -> Warnable [Just e] deflt+-}+   let (e,y) =+           case x of+              Sync.Success y0   -> (Nothing, y0)+              Sync.Exception e0 -> (Just e0, deflt)+   in  Warnable [e] y++fromExceptionNull :: Sync.Exceptional e () -> Warnable e ()+fromExceptionNull = fromException ()++toException :: ([e0] -> e1) -> Warnable e0 a -> Sync.Exceptional e1 a+toException summarize x =+   case x of+      Warnable mes y ->+         case catMaybes mes of+            [] -> Sync.Success y+            es -> Sync.Exception (summarize es)++++warn :: e -> Warnable e ()+warn e = Warnable [Just e] ()++++instance Functor (Warnable e) where+   fmap f x =+      case x of+         Warnable e a -> Warnable e (f a)++instance Applicative (Warnable e) where+   pure = Warnable [] -- [Nothing]?+   f <*> x =+      case f of+         Warnable e0 g ->+            case x of+               Warnable e1 y -> Warnable (mplus e0 e1) (g y)++instance Monad (Warnable e) where+   return = Warnable [] -- [Nothing]?+   fail _msg =+      Warnable+         [Just (error "Warning.fail exception")]+         (error "Warning.fail result")+   x >>= f =+      case x of+         Warnable e0 y ->+            case f y of+               Warnable e1 z -> Warnable (e0 ++ e1) z+++-- * Monad transformer++newtype WarnableT e m a =+   WarnableT {runWarnableT :: m (Warnable e a)}+++fromSynchronousT :: Functor m =>+   a -> Sync.ExceptionalT e m a -> WarnableT e m a+fromSynchronousT deflt (Sync.ExceptionalT mx) =+   WarnableT $ fmap (fromException deflt) mx++++warnT :: (Monad m) =>+   e -> WarnableT e m ()+warnT = WarnableT . return . warn++++instance Functor m => Functor (WarnableT e m) where+   fmap f (WarnableT x) =+      WarnableT (fmap (fmap f) x)++instance Applicative m => Applicative (WarnableT e m) where+   pure = WarnableT . pure . pure+   WarnableT f <*> WarnableT x =+      WarnableT (fmap (<*>) f <*> x)++instance Monad m => Monad (WarnableT e m) where+   return = WarnableT . return . return+   x0 >>= f =+      WarnableT $+      do Warnable ex x <- runWarnableT x0+         Warnable ey y <- runWarnableT (f x)+         return $ Warnable (ex ++ ey) y
+ src/Control/Monad/Label.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{- |+Here we implement a special Reader monad+that can be used to manage a call stack.+This way you can generate exception messages like+\"Corrupt file content encountered+while reading file \'foo.txt\'+while loading document \'bar.doc\'\"+using the functions in "Control.Monad.Exception.Label".+-}+module Control.Monad.Label where++import Control.Applicative (Applicative(pure, (<*>)))++import Control.Monad (MonadPlus, ap, )+import Control.Monad.Fix (MonadFix)+import Control.Monad.Trans (MonadTrans, MonadIO)+import qualified Control.Monad.Reader as Reader+import Control.Monad.Reader (Reader, ReaderT(ReaderT), runReader, runReaderT, )+import Control.Monad.Instances ()+++-- * Plain monad++newtype Label l a = Label { runLabelPriv :: Reader [l] a }+-- newtype Label l a = Label { runLabelPriv :: [l] -> a }+   deriving (Functor, Monad, MonadFix)++{-+instance Functor (Label l) where+   fmap f m = Label $ \l -> f (runLabelPriv m l)++instance Monad (Label l) where+   return a = Label $ \_ -> a+   m >>= k  = Label $ \l -> runLabelPriv (k (runLabelPriv m l)) l++instance MonadFix (Label l) where+   mfix f = Label $ \l -> let a = runLabelPriv (f a) l in a+-}++instance Applicative (Label l) where+   pure  = return+   (<*>) = ap+++runLabel :: Label l a -> [l] -> a+runLabel = runReader . runLabelPriv++ask :: Label l [l]+ask = Label Reader.ask+-- ask = Label id++local :: l -> Label l a -> Label l a+local l m = Label $ Reader.local (l:) $ runLabelPriv m+-- local l m = Label $ runLabelPriv m . (l:)+++++-- * Monad transformer+++newtype LabelT l m a = LabelT { runLabelPrivT :: ReaderT [l] m a }+-- newtype LabelT l m a = LabelT { runLabelPrivT :: l -> m a }+   deriving (Monad, MonadPlus, MonadFix, MonadTrans, MonadIO)++{-+instance (Monad m) => Functor (LabelT l m) where+   fmap f m = LabelT $ \l -> do+      a <- runLabelPrivT m l+      return (f a)++instance (Monad m) => Monad (LabelT l m) where+   return a = LabelT $ \_ -> return a+   m >>= k  = LabelT $ \l -> do+      a <- runLabelPrivT m l+      runLabelPrivT (k a) l+   fail msg = LabelT $ \_ -> fail msg++instance (MonadPlus m) => MonadPlus (LabelT l m) where+   mzero       = LabelT $ \_ -> mzero+   m `mplus` n = LabelT $ \l -> runLabelPrivT m l `mplus` runLabelPrivT n l++instance (MonadFix m) => MonadFix (LabelT l m) where+   mfix f = LabelT $ \l -> mfix $ \a -> runLabelPrivT (f a) l++instance MonadTrans (LabelT l) where+   lift m = LabelT $ \_ -> m++instance (MonadIO m) => MonadIO (LabelT l m) where+   liftIO = lift . liftIO+-}++{-+instance Monad m => Applicative (LabelT l m) where+   pure = return+   (<*>) = ap+-}+++fmapReaderT :: (Functor f) =>+   (a -> b) -> ReaderT r f a -> ReaderT r f b+fmapReaderT f m = ReaderT $ \l -> fmap f $ runReaderT m l++instance (Functor m) => Functor (LabelT l m) where+   fmap f m = LabelT $ fmapReaderT f $ runLabelPrivT m+++pureReaderT :: (Applicative f) =>+   a -> ReaderT r f a+pureReaderT a = ReaderT $ const $ pure a++apReaderT :: (Applicative f) =>+   ReaderT r f (a -> b) ->+   ReaderT r f a ->+   ReaderT r f b+apReaderT f x = ReaderT $ \r -> runReaderT f r <*> runReaderT x r++instance Applicative m => Applicative (LabelT l m) where+   pure a  = LabelT $ pureReaderT a+   f <*> x = LabelT $ runLabelPrivT f `apReaderT` runLabelPrivT x+++runLabelT :: Monad m => LabelT l m a -> [l] -> m a+runLabelT = runReaderT . runLabelPrivT++askT :: Monad m => LabelT l m [l]+askT = LabelT Reader.ask++localT :: Monad m => l -> LabelT l m a -> LabelT l m a+localT l m = LabelT $ Reader.local (l:) $ runLabelPrivT m
+ src/System/IO/Exception/BinaryFile.hs view
@@ -0,0 +1,30 @@+{- |+Files with binary content.+-}+module System.IO.Exception.BinaryFile where++import System.IO.Exception.File (EIO, close, )+import Control.Monad.Exception.Synchronous (bracketT, )+import System.IO.Straight (ioToExceptionalSIO, )+import System.IO (Handle, IOMode, )+import qualified System.IO as IO+import Data.Word (Word8, )+import Data.Char (ord, chr, )+++open :: FilePath -> IOMode -> EIO Handle+open name mode =+   ioToExceptionalSIO $ IO.openBinaryFile name mode++with ::+   FilePath -> IOMode -> (Handle -> EIO r) -> EIO r+with name mode =+   bracketT (open name mode) close++getByte :: Handle -> EIO Word8+getByte h =+   ioToExceptionalSIO $ fmap (fromIntegral . ord) $ IO.hGetChar h++putByte :: Handle -> Word8 -> EIO ()+putByte h c =+   ioToExceptionalSIO $ IO.hPutChar h (chr . fromIntegral $ c)
+ src/System/IO/Exception/File.hs view
@@ -0,0 +1,12 @@+module System.IO.Exception.File where++import System.IO.Straight (ExceptionalT, IOException, SIO, ioToExceptionalSIO, )+import qualified System.IO as IO+-- import System.IO (Handle, IOMode, )+++type EIO = ExceptionalT IOException SIO++close :: IO.Handle -> EIO ()+close h =+   ioToExceptionalSIO $ IO.hClose h
+ src/System/IO/Exception/TextFile.hs view
@@ -0,0 +1,50 @@+{- |+Files with text content.+-}+module System.IO.Exception.TextFile where++import System.IO.Exception.File (EIO, close, )+import qualified Control.Monad.Exception.Synchronous  as Sync+import qualified Control.Monad.Exception.Asynchronous as Async+import Control.Monad.Exception.Synchronous (bracketT, )+import System.IO.Straight (SIO, ioToExceptionalSIO, unsafeInterleaveSIO, )+import System.IO (Handle, IOMode, )+import qualified System.IO as IO++import System.IO.Error (isEOFError, )+import Control.Exception (IOException)++import Prelude hiding (getChar)+++open :: FilePath -> IOMode -> EIO Handle+open name mode =+   ioToExceptionalSIO $ IO.openFile name mode++with ::+   FilePath -> IOMode -> (Handle -> EIO r) -> EIO r+with name mode =+   bracketT (open name mode) close++getChar :: Handle -> EIO Char+getChar h =+   ioToExceptionalSIO $ IO.hGetChar h++getContentsSynchronous :: Handle -> EIO String+getContentsSynchronous h =+   Sync.manyT+      -- candidate for toMaybe+      (\e -> if isEOFError e then Nothing else Just e)+      (:) [] (getChar h)++{- |+This calls 'unsafeInterleaveIO'.+Maybe we should also attach 'unsafe' to this function name?+-}+getContentsAsynchronous :: Handle -> SIO (Async.Exceptional IOException String)+getContentsAsynchronous h =+   Async.manySynchronousT unsafeInterleaveSIO (:) [] (getChar h)++putChar :: Handle -> Char -> EIO ()+putChar h c =+   ioToExceptionalSIO $ IO.hPutChar h c
+ src/System/IO/Straight.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{- |+Module defining the type for exception free I/O.+Exceptional results in SIO must be represented by traditional error codes.++If you want to turn an IO action into 'SIO'+you must convert it to @ExceptionalT IOException SIO a@+by 'ioToExceptionalSIO' (or 'Control.Monad.Trans.liftIO')+and then handle the 'IOException's using 'SyncExc.resolveT'.+-}+module System.IO.Straight (+   SIO, sioToIO, ioToExceptionalSIO, unsafeInterleaveSIO,+   ExceptionalT, IOException,+   ) where++import Control.Monad.Exception.Synchronous+   (Exceptional(Success, Exception), ExceptionalT(ExceptionalT), )+import qualified Control.Monad.Exception.Synchronous as SyncExc+import Control.Exception (IOException)+import System.IO.Error (try)+import Control.Monad.Trans (MonadIO, liftIO, )++import System.IO.Unsafe (unsafeInterleaveIO, )+++{- |+An I/O action of type 'SIO' cannot skip following SIO actions+as a result of exceptional outcomes like \"File not found\".+However an 'error' can well break the program.+-}+newtype SIO a = SIO (IO a) -- {sioToIO :: IO a}+   deriving (Functor, Monad)+++sioToIO :: SIO a -> IO a+sioToIO (SIO x) = x++ioToExceptionalSIO :: IO a -> ExceptionalT IOException SIO a+ioToExceptionalSIO =+   ExceptionalT . SIO . fmap (either Exception Success) . try+++unsafeInterleaveSIO :: SIO a -> SIO a+unsafeInterleaveSIO (SIO io) = SIO $ unsafeInterleaveIO io++-- helper classes for defining the MonadIO instance of SIO++{-+It's important that no-one else can define instances of MonadSIO+because we cannot assert absence of exceptions in other monads.+It is also important not to export 'toSIO',+since we can also not assert absence of exceptions in IO actions.+-}+class Monad m => MonadSIO m where toSIO :: IO a -> m a+instance MonadSIO SIO where toSIO = SIO++class ContainsIOException e where fromIOException :: IOException -> e+instance ContainsIOException IOException where fromIOException = id+++instance (MonadSIO m, ContainsIOException e) =>+            MonadIO (ExceptionalT e m) where+   liftIO =+      ExceptionalT . toSIO .+      fmap (either (Exception . fromIOException) Success) . try