packages feed

FailT (empty) → 0.1.0.0

raw patch · 11 files changed

+1157/−0 lines, 11 filesdep +FailTdep +QuickCheckdep +basesetup-changed

Dependencies added: FailT, QuickCheck, base, doctest, exceptions, hspec, mtl, quickcheck-classes, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for `FailT`++## 0.1.0.0++* Initial release
+ FailT.cabal view
@@ -0,0 +1,85 @@+name:                FailT+version:             0.1.0.0+synopsis:            A 'FailT' monad transformer that plays well with 'MonadFail'+description:+    Fail gracefully when stuck in a 'MonadFail'+    .+    λ> runFailT (fail "Failure!?" >> pure "Success!!")+    Left "Failure!?"+    λ> runFailT (fail "Failure!?" <|> pure "Success!!")+    Right "Success!!"+    λ> runFailT (pure ["Success!!"] <> fail "Failure!?" <> pure ["At", "Last!"])+    Right ["Success!!","At","Last!"]+    .+++homepage:            https://github.com/lehins/FailT+license:              BSD3+license-file:         LICENSE+author:               Alexey Kuleshevich+maintainer:           alexey@kuleshevi.ch+copyright:            2022-2023 Alexey Kuleshevich+category:             Control, Failure+build-type:           Simple+extra-source-files:   README.md+                    , CHANGELOG.md+cabal-version:        1.18+tested-with:          GHC == 8.0.2+                    , GHC == 8.2.2+                    , GHC == 8.4.4+                    , GHC == 8.6.5+                    , GHC == 8.8.4+                    , GHC == 8.10.7+                    , GHC == 9.0.2+                    , GHC == 9.2.5+                    , GHC == 9.4.4++library+  hs-source-dirs:     src+  exposed-modules:    Control.Monad.Trans.Fail+                    , Control.Monad.Trans.Fail.String+                    , Control.Monad.Trans.Fail.Text++  build-depends:      base >= 4.8 && < 5+                    , exceptions+                    , mtl+                    , text++  default-language:   Haskell2010+  ghc-options:        -Wall+++test-suite doctests+  type:               exitcode-stdio-1.0+  hs-source-dirs:     tests+  main-is:            doctests.hs+  build-depends:      base+                    , doctest >= 0.15+                    , exceptions+                    , FailT+  default-language:   Haskell2010+  ghc-options:       -Wall+                     -fno-warn-orphans+                     -threaded++test-suite tests+  type:               exitcode-stdio-1.0+  hs-source-dirs:     tests+  main-is:            Main.hs+  other-modules:      Test.Control.Monad.Trans.FailSpec+  build-depends:      base+                    , FailT+                    , hspec+                    , mtl+                    , QuickCheck+                    , quickcheck-classes >= 0.6++  default-language:   Haskell2010+  ghc-options:        -Wall+                      -fno-warn-orphans+                      -threaded+                      -with-rtsopts=-N2++source-repository head+  type:     git+  location: https://github.com/lehins/FailT
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexey Kuleshevich (c) 2022-2023++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.++    * Neither the name of Alexey Kuleshevich nor the names of other+      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.
+ README.md view
@@ -0,0 +1,136 @@+# FailT++This package solves a fairly simple, but very common problem of gracefully converting a+monadic computation that uses `MonadFail` into either a result or a string failure+message(s).++## Motivation++When we have a function that can fail in a `MonadFail`, there is no instance in `base`+that would allow us to get the failure message without a runtime exception. It is best to+demonstrate the problem with an example.++Here is+[`formatParseM`](https://hackage.haskell.org/package/time/docs/Data-Time-Format-ISO8601.html#v:formatParseM)+function from the [`time`](https://hackage.haskell.org/package/time) package, which is+designed to parse time:++```haskell+formatParseM :: MonadFail m => Format t -> String -> m t+```++We can use it out of the box with various packages like `aeson`, `attoparsec`, `binary`,+etc. Here is how it could be used to successfully parse a string with time in the `IO`+monad:++```haskell+λ> import Data.Time (UTCTime)+λ> import Data.Time.Format.ISO8601 (formatParseM, iso8601Format)+λ> formatParseM iso8601Format "2023-01-08T00:29:00Z" :: IO UTCTime+2023-01-08 00:29:00 UTC+```++However, when it comes to bad input, there is not a single monad in `base` or other+package that is wired with GHC that has a `MonadFail` instance, which would allow us to+gracefully fail and retrieve the error message. Below are all the instances from `base`:++```haskell+λ> formatParseM iso8601Format "Bad time" :: IO UTCTime+*** Exception: user error (no parse of "Bad time")+λ> formatParseM iso8601Format "Bad time" :: Maybe UTCTime+Nothing+λ> formatParseM iso8601Format "Bad time" :: [UTCTime]+[]+```++## Solution++This is where `FailT` package comes to help:++```haskell+λ> import Control.Monad.Trans.Fail.String+λ> runFail $ formatParseM iso8601Format "Bad time" :: Either String UTCTime+Left "no parse of \"Bad time\""+λ> runFail $ formatParseM iso8601Format "2023-01-08T00:29:00Z" :: Either String UTCTime+Right 2023-01-08 00:29:00 UTC+```++## Features++### Monad transformer++Naturally, as the package name suggests, it provides a `FailT` monad transformer.++The example above used the `Fail` type synonym, whcih is restricts the underlying monad to+`Identity`. Below is the example of running `FailT` with `IO`:++```haskell+λ> import Control.Monad.IO.Class+λ> runFailT (liftIO . print . utctDayTime =<< formatParseM iso8601Format "2023-01-08T00:29:00Z")+1740s+Right ()+λ> runFailT (liftIO . print . utctDayTime =<< formatParseM iso8601Format "Bad input")+Left "no parse of \"Bad input\""+```++### Polymorphic failure++Thus far examples only showed using `String` type for failure messages, but that is not a+requirement. This library was designed to be agnostic with respect to failure message type+with restriction to `IsString` type class. Reason for the constraint is because the+failure message normally originates with the `fail` function and is string like by its+nature:++```haskell+fail :: MonadFail m => String -> m ()+```++The more general implementation is located in `import Control.Monad.Trans.Fail`, which+contains polymorphic implementation that allows the user to choose a more specific type+for the failure type `e`:++```+runFailT :: (IsString e, Semigroup e, Functor m) => FailT e m a -> m (Either e a)+```++This package implements convenience modules:++* `Control.Monad.Trans.Fail.String`+* `Control.Monad.Trans.Fail.Text`++which provide type synonyms and functions with more restricted failure types: `String` and+`Text` respectfully. Modules were designed to be drop-in replacements of each other.++### Convenient instances++There are many type class instances for `FailT` monad. Such as instances for type classes+from `mtl` package, `MonadIO` instance, etc. Most of them rely on the instances of the+underlying monad by lifting the functionality. However, here are some of the more notable+and useful instances that do not require corresponding instances from the underlying+monad:++* `MonadFail` with `Monad`ic sequencing, which allow to stop the computation upon the first+  invocation of `fail`.++  ```haskell+  λ> runFailT (fail "Failure!?" >> pure "Success!!")+  Left "Failure!?"+  ```++* `Alternative`, which will continue until the first successful computation is encountered.++  ```haskell+  λ> runFailT (fail "Failure!?" <|> pure "Success!!")+  Right "Success!!"+  ```++* `Semigroup` and `Monoid`, which will not stop until **all** of the actions are executed.+  Produced at the end are either all of the failures or the results of all of the+  successful cases combined with `<>`++  ```haskell+  λ> runFailT (pure ["Success!!"] <> fail "Failure!?" <> pure ["At", "Last!"])+  Right ["Success!!","At","Last!"]+  λ> runFailT mempty :: IO (Either String ())+  Left "No failure reason given"+  ```
+ Setup.hs view
@@ -0,0 +1,7 @@+import Distribution.Simple++main :: IO ()+main = defaultMain++#endif+
+ src/Control/Monad/Trans/Fail.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Control.Monad.Trans.Fail+-- Copyright   : (c) Alexey Kuleshevich 2022-2023+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability   : experimental+-- Portability : non-portable+module Control.Monad.Trans.Fail (+  -- * Fail+  Fail,+  runFail,+  runFailLast,+  runFailAgg,+  errorFail,+  errorFailWithoutStackTrace,++  -- * FailT+  FailT (..),+  FailException (..),+  failT,+  runFailT,+  runFailLastT,+  runFailAggT,+  hoistFailT,+  mapFailT,+  mapErrorFailT,+  mapErrorsFailT,+  exceptFailT,+  throwFailT,++  -- * Helpers+  liftCatch,+  liftListen,+  liftPass,+) where++import Control.Applicative+import Control.Exception+import Control.Monad.Catch (MonadThrow (throwM))+import Control.Monad.Cont+import Control.Monad.Except+import qualified Control.Monad.Fail as F+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Zip+import Data.Bifunctor (first)+import Data.Functor.Classes+import Data.Functor.Identity+import Data.List (intersperse)+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as Semi+import Data.Typeable+import GHC.Exts+import GHC.Stack+#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif++-- | `FailT` transformer with `Identity` as the base monad.+type Fail e = FailT e Identity++-- | Unwrap the pure `Fail` monad and reveal the underlying result of monadic+-- computation.+--+-- >>> runFail (fail "Something went wrong") :: Either String ()+-- Left "Something went wrong"+-- >>> runFail (failT "Something went wrong" >> pure ())+-- Left "Something went wrong"+-- >>> import Control.Applicative+-- >>> runFail (failT "Something could have gone wrong" <|> pure ())+-- Right ()+--+-- All errors accrued during the monadic computation will be combined using the+-- `Semi.Semigroup` instance and delimited by a comma:+--+-- >>> runFail (fail "One thing went wrong" <|> fail "Another thing went wrong") :: Either String ()+-- Left "One thing went wrong, Another thing went wrong"+--+-- Failing with one of instances functions `mempty` or `empty` will yield a no-reason+-- error report:+--+-- >>> runFail mempty :: Either String ()+-- Left "No failure reason given"+runFail :: (IsString e, Semi.Semigroup e) => Fail e a -> Either e a+runFail = runIdentity . runFailT+{-# INLINE runFail #-}++-- | This is a variant of `runFailAgg` where only the error reported for the very last+-- failed computation will be produced and others discarded. This is useful when it is not+-- relevant to retain information about all the attempts and only the last one matters,+-- eg. parsing with backtracking.+runFailLast :: IsString e => Fail e a -> Either e a+runFailLast = runIdentity . runFailLastT+{-# INLINE runFailLast #-}++-- | Convert a `Fail` monad computation in an `Either`, where the `Left` will contain all+-- failures in the same order they where received, or `Right` upon a successful computation.+--+-- >>> runFailAgg (fail "One bad thing" <|> fail "Another bad thing") :: Either [String] ()+-- Left ["One bad thing","Another bad thing"]+-- >>> runFailAgg (fail "A bad thing" <|> pure "A good thing") :: Either [String] String+-- Right "A good thing"+runFailAgg :: Fail e a -> Either [e] a+runFailAgg = runIdentity . runFailAggT+{-# INLINE runFailAgg #-}++-- | Throw an error if there was a failure, otherwise return the result of+-- computation. Use `throwFailT` in case you'd like to handle an actual exception in some+-- other underlying monad.+--+-- >>> errorFail (fail "This didn't work" :: Fail String ())+-- *** Exception: "This didn't work"+-- CallStack (from HasCallStack):+-- ...+-- >>> errorFail (fail "This didn't work" <|> pure "That Worked" :: Fail String String)+-- "That Worked"+errorFail :: (Show e, HasCallStack) => Fail e a -> a+errorFail = either (error . toFailureDelimited . fmap show) id . runFailAgg++-- | Same as `errorFail`, but without the stack trace:+--+-- >>> errorFailWithoutStackTrace (fail "This didn't work" :: Fail String ())+-- *** Exception: "This didn't work"+-- >>> errorFailWithoutStackTrace (fail "This didn't work" <|> pure "That Worked" :: Fail String String)+-- "That Worked"+errorFailWithoutStackTrace :: Show e => Fail e a -> a+errorFailWithoutStackTrace =+  either (errorWithoutStackTrace . toFailureDelimited . fmap show) id . runFailAgg++-- | Fail monad transformer that plays well with `F.MonadFail` type class.+newtype FailT e m a = FailT (m (Either [e] a))++-- | Similar to `fail`, but it is not restricted to `String`.+failT :: Applicative m => e -> FailT e m a+failT = FailT . pure . Left . pure++-- | Similar to `runFail`, except underlying monad is not restricted to `Identity`.+--+-- Unwrap the `FailT` monad transformer and produce an action that can be executed in+-- the underlying monad and, which will produce either a comma delimited error message+-- upon a failure or the result otherwise.+--+-- >>> runFailT (failT "Could have failed" <|> liftIO (putStrLn "Nothing went wrong"))+-- Nothing went wrong+-- Right ()+runFailT :: (IsString e, Semi.Semigroup e, Functor m) => FailT e m a -> m (Either e a)+runFailT (FailT f) = either (Left . toFailureDelimited) Right <$> f+{-# INLINE runFailT #-}++-- | Similar to `runFailLast`, except underlying monad is not restricted to `Identity`.+runFailLastT :: (IsString e, Functor m) => FailT e m a -> m (Either e a)+runFailLastT (FailT f) = either (Left . NE.last . toFailureNonEmpty) Right <$> f+{-# INLINE runFailLastT #-}++-- | Similar to `runFailAgg`, except underlying monad is not restricted to `Identity`.+runFailAggT :: FailT e m a -> m (Either [e] a)+runFailAggT (FailT f) = f+{-# INLINE runFailAggT #-}++-- | Change the underlying monad with the hoisting function.+hoistFailT :: (forall a. m a -> n a) -> FailT e m b -> FailT e n b+hoistFailT f = FailT . f . runFailAggT+{-# INLINE hoistFailT #-}++-- | Map a function over the underlying representation of the `FailT` monad.+mapFailT :: (m (Either [e] a) -> n (Either [e] b)) -> FailT e m a -> FailT e n b+mapFailT f = FailT . f . runFailAggT+{-# INLINE mapFailT #-}++-- | Map a function over the error type in the `FailT` monad.+mapErrorFailT :: Functor m => (e -> e') -> FailT e m a -> FailT e' m a+mapErrorFailT f = mapErrorsFailT (map f)+{-# INLINE mapErrorFailT #-}++-- | Map a function over the aggregation of errors in the `FailT` monad. Could be used for+-- example for clearing our all of the aggregated error messages:+--+-- >>> runFail (mapErrorsFailT (const []) $ failT "Something went wrong") :: Either String ()+-- Left "No failure reason given"+mapErrorsFailT :: Functor m => ([e] -> [e']) -> FailT e m a -> FailT e' m a+mapErrorsFailT f (FailT m) = FailT (fmap (first f) m)+{-# INLINE mapErrorsFailT #-}++-- | Convert a `FailT` computation into an `ExceptT`.+--+-- >>> exceptFailT (fail "A bad thing" >> pure () :: Fail String ())+-- ExceptT (Identity (Left FailException+-- "A bad thing"+-- CallStack (from HasCallStack):+-- ...+exceptFailT :: (HasCallStack, Typeable e, Show e, Monad m) => FailT e m a -> ExceptT FailException m a+exceptFailT m =+  ExceptT $+    runFailAggT m >>= \case+      Right x -> pure $ Right x+      Left errMsgs ->+        pure $+          Left $+            FailException+              { failMessages = errMsgs+              , failCallStack = ?callStack+              }+{-# INLINE exceptFailT #-}++-- | An exception that is produced by the `FailT` monad transformer.+data FailException where+  FailException+    :: (Typeable e, Show e)+    => { failMessages :: [e]+       , failCallStack :: CallStack+       }+    -> FailException++instance Show FailException where+  show FailException{failMessages, failCallStack} =+    mconcat $+      intersperse "\n" $+        "FailException"+          : NE.toList (toFailureNonEmpty (show <$> failMessages))+          ++ [prettyCallStack failCallStack]++instance Exception FailException++toFailureNonEmpty :: IsString e => [e] -> NE.NonEmpty e+toFailureNonEmpty xs =+  case NE.nonEmpty xs of+    Nothing -> "No failure reason given" NE.:| []+    Just ne -> ne++toFailureDelimited :: (IsString e, Semi.Semigroup e) => [e] -> e+toFailureDelimited = Semi.sconcat . NE.intersperse ", " . toFailureNonEmpty++-- | Use the `MonadThrow` instance to raise a `FailException` in the underlying monad.+--+-- >>> throwFailT (failT "One thing went wrong")+-- *** Exception: FailException+-- "One thing went wrong"+-- ...+-- >>> throwFailT (failT "One thing went wrong") :: Maybe ()+-- Nothing+throwFailT :: (HasCallStack, Typeable e, Show e, MonadThrow m) => FailT e m a -> m a+throwFailT f = do+  runFailAggT f >>= \case+    Right x -> pure x+    Left errMsgs ->+      throwM $+        FailException+          { failMessages = errMsgs+          , failCallStack = ?callStack+          }+{-# INLINEABLE throwFailT #-}++instance Functor m => Functor (FailT e m) where+  fmap f (FailT m) = FailT (fmap (fmap f) m)+  {-# INLINE fmap #-}++instance Monad m => Applicative (FailT e m) where+  pure = FailT . pure . Right+  {-# INLINE pure #-}++  FailT m <*> FailT k =+    FailT $+      m >>= \case+        Left merr -> pure $ Left merr+        Right f ->+          k >>= \case+            Left kerr -> pure $ Left kerr+            Right a -> pure $ Right (f a)+  {-# INLINE (<*>) #-}+  FailT m *> FailT k = FailT $ m *> k+  {-# INLINE (*>) #-}++-- | Short-circuites on the first failing operation.+instance (IsString e, Monad m) => Monad (FailT e m) where+  FailT m >>= k =+    FailT $+      m >>= \case+        Left merr -> return $ Left merr+        Right a -> runFailAggT $ k a+  {-# INLINE (>>=) #-}++#if !(MIN_VERSION_base(4,13,0))+  fail = FailT . return . Left . pure . fromString+  {-# INLINE fail #-}+#endif++instance (IsString e, Monad m) => F.MonadFail (FailT e m) where+  fail = FailT . return . Left . pure . fromString+  {-# INLINE fail #-}++instance Foldable f => Foldable (FailT e f) where+  foldMap f (FailT m) = foldMap (either (const mempty) f) m+  {-# INLINE foldMap #-}++instance Traversable f => Traversable (FailT e f) where+  traverse f (FailT m) = FailT <$> traverse (either (pure . Left) (fmap Right . f)) m+  {-# INLINE traverse #-}++-- | Short-circuits on the first successful operation, combines failures otherwise.+instance Monad m => Alternative (FailT e m) where+  empty = FailT $ pure (Left [])+  {-# INLINE empty #-}+  FailT m <|> FailT k = FailT $ do+    m >>= \case+      Left merr ->+        k >>= \case+          Left kerr -> pure $ Left $ merr ++ kerr+          Right result -> pure $ Right $ result+      Right x -> pure (Right x)+  {-# INLINEABLE (<|>) #-}++-- | Executes all monadic actions and combines all successful results using a `Semi.Semigroup`+-- instance. Combines together all failures as well, until a successful operation.+instance (Monad m, Semi.Semigroup a) => Semi.Semigroup (FailT e m a) where+  (<>) (FailT m) (FailT k) = FailT $ do+    mres <- m+    kres <- k+    case mres of+      Left merr ->+        case kres of+          Left kerr -> pure $ Left $ merr ++ kerr+          Right y -> pure $ Right y+      Right x ->+        case kres of+          Left _kerr -> pure $ Right x+          Right y -> pure $ Right (x Semi.<> y)+  {-# INLINEABLE (<>) #-}++instance (Monad m, Semi.Semigroup a) => Monoid (FailT e m a) where+  mempty = empty+  {-# INLINE mempty #-}+#if !(MIN_VERSION_base(4,11,0))+  mappend = (Semi.<>)+#endif++instance (IsString e, MonadIO m) => MonadIO (FailT e m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance MonadTrans (FailT e) where+  lift = FailT . fmap Right+  {-# INLINE lift #-}++instance (IsString e, MonadZip m) => MonadZip (FailT e m) where+  mzipWith f (FailT a) (FailT b) = FailT $ mzipWith (liftA2 f) a b+  {-# INLINE mzipWith #-}++#if MIN_VERSION_base(4,12,0)+instance Contravariant f => Contravariant (FailT e f) where+  contramap f = FailT . contramap (fmap f) . runFailAggT+  {-# INLINE contramap #-}+#endif++instance (Eq e, Eq1 m) => Eq1 (FailT e m) where+  liftEq eq (FailT x) (FailT y) = liftEq (liftEq eq) x y+  {-# INLINE liftEq #-}++instance (Ord e, Ord1 m) => Ord1 (FailT e m) where+  liftCompare comp (FailT x) (FailT y) =+    liftCompare (liftCompare comp) x y+  {-# INLINE liftCompare #-}++instance (Read e, Read1 m) => Read1 (FailT e m) where+  liftReadsPrec rp rl =+    readsData $+      readsUnaryWith (liftReadsPrec rp' rl') "FailT" FailT+    where+      rp' = liftReadsPrec rp rl+      rl' = liftReadList rp rl++instance (Show e, Show1 m) => Show1 (FailT e m) where+  liftShowsPrec sp sl d (FailT m) =+    showsUnaryWith (liftShowsPrec sp' sl') "FailT" d m+    where+      sp' = liftShowsPrec sp sl+      sl' = liftShowList sp sl++instance (Eq e, Eq1 m, Eq a) => Eq (FailT e m a) where+  (==) = eq1+  {-# INLINE (==) #-}++instance (Ord e, Ord1 m, Ord a) => Ord (FailT e m a) where+  compare = compare1+  {-# INLINE compare #-}++instance (Read e, Read1 m, Read a) => Read (FailT e m a) where+  readsPrec = readsPrec1++instance (Show e, Show1 m, Show a) => Show (FailT e m a) where+  showsPrec = showsPrec1++instance (IsString e, MonadReader r m) => MonadReader r (FailT e m) where+  ask = lift ask+  {-# INLINE ask #-}+  local = mapFailT . local+  {-# INLINE local #-}+  reader = lift . reader+  {-# INLINE reader #-}++instance (IsString e, MonadState s m) => MonadState s (FailT e m) where+  get = lift get+  {-# INLINE get #-}+  put = lift . put+  {-# INLINE put #-}+  state = lift . state+  {-# INLINE state #-}++instance (IsString e, MonadError e m) => MonadError e (FailT e m) where+  throwError = lift . throwError+  {-# INLINE throwError #-}+  catchError = liftCatch catchError+  {-# INLINE catchError #-}++instance (IsString e, MonadWriter w m) => MonadWriter w (FailT e m) where+  writer = lift . writer+  {-# INLINE writer #-}+  tell = lift . tell+  {-# INLINE tell #-}+  listen = liftListen listen+  {-# INLINE listen #-}+  pass = liftPass pass+  {-# INLINE pass #-}++instance (IsString e, MonadCont m) => MonadCont (FailT e m) where+  callCC = liftCallCC callCC+  {-# INLINE callCC #-}++-- | Lift a @callCC@ operation to the new monad.+liftCallCC+  :: (((Either [e] a -> m (Either [e] b)) -> m (Either [e] a)) -> m (Either [e] a))+  -> ((a -> FailT e m b) -> FailT e m a)+  -> FailT e m a+liftCallCC ccc f = FailT $ ccc $ \c ->+  runFailAggT (f (\a -> FailT $ c (Right a)))+{-# INLINE liftCallCC #-}++-- | Lift a @`catchE`@ operation to the new monad.+liftCatch+  :: (m (Either [e] a) -> (e -> m (Either [e] a)) -> m (Either [e] a))+  -> FailT e m a+  -> (e -> FailT e m a)+  -> FailT e m a+liftCatch f m h = FailT $ f (runFailAggT m) (runFailAggT . h)+{-# INLINE liftCatch #-}++-- | Lift a @`listen`@ operation to the new monad.+liftListen+  :: Monad m+  => (m (Either [e] a) -> m (Either [e] a, w))+  -> (FailT e m) a+  -> (FailT e m) (a, w)+liftListen l = mapFailT $ \m -> do+  (a, w) <- l m+  return $! fmap (\r -> (r, w)) a+{-# INLINE liftListen #-}++-- | Lift a @`pass`@ operation to the new monad.+liftPass+  :: Monad m+  => (m (Either [e] a, w -> w) -> m (Either [e] a))+  -> (FailT e m) (a, w -> w)+  -> (FailT e m) a+liftPass p = mapFailT $ \m -> p $ do+  a <- m+  return $! case a of+    Left errs -> (Left errs, id)+    Right (v, f) -> (Right v, f)+{-# INLINE liftPass #-}
+ src/Control/Monad/Trans/Fail/String.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      : Control.Monad.Trans.Fail.String+-- Copyright   : (c) Alexey Kuleshevich 2022-2023+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability   : experimental+-- Portability : non-portable+--+-- This module contains a synonym for __@`F.FailT` e m a@__ transformer, where failure+-- type __@e@__ is restricted to __@`String`@__. All functions in this module have the same+-- names and are a drop-in replacement for "Control.Monad.Trans.Fail" module, except with+-- monomorphic failure type.+module Control.Monad.Trans.Fail.String (+  Fail,+  runFail,+  runFailLast,+  runFailAgg,+  errorFail,+  errorFailWithoutStackTrace,+  FailT,+  F.FailException (..),+  failT,+  runFailT,+  runFailLastT,+  runFailAggT,+  hoistFailT,+  mapFailT,+  mapErrorFailT,+  mapErrorsFailT,+  exceptFailT,+  throwFailT,+) where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.Except+import qualified Control.Monad.Trans.Fail as F+import GHC.Stack++-- | Version of `F.Fail` restricted to `String`+type Fail = F.Fail String++-- | Version of `F.runFail` restricted to `String`+runFail :: Fail a -> Either String a+runFail = F.runFail+{-# INLINE runFail #-}++-- | Version of `F.runFailLast` restricted to `String`+runFailLast :: Fail a -> Either String a+runFailLast = F.runFailLast+{-# INLINE runFailLast #-}++-- | Version of `F.runFailAgg` restricted to `String`+runFailAgg :: Fail a -> Either [String] a+runFailAgg = F.runFailAgg+{-# INLINE runFailAgg #-}++-- | Version of `F.errorFail` restricted to `String`+--+-- Throw an error if there was a failure, otherwise return the result of monadic+-- computation. Use `throwFailT` in case you'd like to handle an actual exception.+errorFail :: HasCallStack => Fail a -> a+errorFail = F.errorFail++-- | Version of `F.runFail` restricted to `String`+--+-- Same as `errorFail`, but without the stack trace:+--+-- >>> errorFailWithoutStackTrace (fail "This didn't work" :: Fail ())+-- *** Exception: "This didn't work"+-- >>> import Control.Applicative+-- >>> errorFailWithoutStackTrace (fail "This didn't work" <|> pure "That Worked" :: Fail String)+-- "That Worked"+errorFailWithoutStackTrace :: Fail a -> a+errorFailWithoutStackTrace = F.errorFailWithoutStackTrace++-- | Version of `F.FailT` restricted to `String`+--+-- Fail monad transformer that plays well with `MonadFail`+type FailT = F.FailT String++-- | Version of `F.failT` restricted to `String`+--+-- Monomorphic synonym for `fail`+failT :: Applicative m => String -> FailT m a+failT = F.failT+{-# INLINE failT #-}++-- | Version of `F.runFailT` restricted to `String`+runFailT :: Functor m => FailT m a -> m (Either String a)+runFailT = F.runFailT+{-# INLINE runFailT #-}++-- | Version of `F.runFailLastT` restricted to `String`+runFailLastT :: Functor m => FailT m a -> m (Either String a)+runFailLastT = F.runFailLastT+{-# INLINE runFailLastT #-}++-- | Version of `F.runFailAggT` restricted to `String`+runFailAggT :: FailT m a -> m (Either [String] a)+runFailAggT = F.runFailAggT+{-# INLINE runFailAggT #-}++-- | Version of `F.hoistFailT` restricted to `String`+--+-- Change the underlying monad with the hoisting function+hoistFailT :: (forall a. m a -> n a) -> FailT m b -> FailT n b+hoistFailT = F.hoistFailT+{-# INLINE hoistFailT #-}++-- | Version of `F.mapFailT` restricted to `String`+--+-- Map a function over the underlying representation of the `FailT` monad.+mapFailT :: (m (Either [String] a) -> n (Either [String] b)) -> FailT m a -> FailT n b+mapFailT = F.mapFailT+{-# INLINE mapFailT #-}++-- | Version of `F.mapErrorFail`, where resulting type is restricted to `String`+--+-- Map a function over the error type in the `FailT` monad.+mapErrorFailT :: Functor m => (e -> String) -> F.FailT e m a -> FailT m a+mapErrorFailT = F.mapErrorFailT+{-# INLINE mapErrorFailT #-}++-- | Version of `F.mapErrorsFail`, where resulting type is restricted to `String`+--+-- Map a function over the aggregation of errors in the `FailT` monad. Could be used for+-- example for clearing our all of the aggregated error messages:+--+-- >>> runFail (mapErrorsFailT (const []) $ failT "Something went wrong") :: Either String ()+-- Left "No failure reason given"+mapErrorsFailT :: Functor m => ([e] -> [String]) -> F.FailT e m a -> FailT m a+mapErrorsFailT = F.mapErrorsFailT+{-# INLINE mapErrorsFailT #-}++-- | Version of `F.exceptFailT` restricted to `String`+exceptFailT :: (HasCallStack, Monad m) => FailT m a -> ExceptT F.FailException m a+exceptFailT = F.exceptFailT+{-# INLINE exceptFailT #-}++-- | Version of `F.throwFailT` restricted to `String`+throwFailT :: (HasCallStack, MonadThrow m) => FailT m a -> m a+throwFailT = F.throwFailT+{-# INLINE throwFailT #-}
+ src/Control/Monad/Trans/Fail/Text.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      : Control.Monad.Trans.Fail.Text+-- Copyright   : (c) Alexey Kuleshevich 2022-2023+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability   : experimental+-- Portability : non-portable+--+-- This module contains a synonym for __@`F.FailT` e m a@__ transformer, where failure+-- type __@e@__ is restricted to __@`Text`@__. All functions in this module have the same+-- names and are a drop-in replacement for "Control.Monad.Trans.Fail" module, except with+-- monomorphic failure type.+module Control.Monad.Trans.Fail.Text (+  Fail,+  runFail,+  runFailLast,+  runFailAgg,+  errorFail,+  errorFailWithoutStackTrace,+  FailT,+  F.FailException (..),+  failT,+  runFailT,+  runFailLastT,+  runFailAggT,+  hoistFailT,+  mapFailT,+  mapErrorFailT,+  mapErrorsFailT,+  exceptFailT,+  throwFailT,+) where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.Except+import qualified Control.Monad.Trans.Fail as F+import Data.Text (Text)+import GHC.Stack++-- | Version of `F.Fail` restricted to `Text`+type Fail = F.Fail Text++-- | Version of `F.runFail` restricted to `Text`+runFail :: Fail a -> Either Text a+runFail = F.runFail+{-# INLINE runFail #-}++-- | Version of `F.runFailLast` restricted to `Text`+runFailLast :: Fail a -> Either Text a+runFailLast = F.runFailLast+{-# INLINE runFailLast #-}++-- | Version of `F.runFailAgg` restricted to `Text`+runFailAgg :: Fail a -> Either [Text] a+runFailAgg = F.runFailAgg+{-# INLINE runFailAgg #-}++-- | Version of `F.errorFail` restricted to `Text`+--+-- Throw an error if there was a failure, otherwise return the result of monadic+-- computation. Use `throwFailT` in case you'd like to handle an actual exception.+errorFail :: HasCallStack => Fail a -> a+errorFail = F.errorFail++-- | Version of `F.errorFailWithoutStackTrace` restricted to `Text`+--+-- Same as `errorFail`, but without the stack trace:+--+-- >>> errorFailWithoutStackTrace (fail "This didn't work" :: Fail ())+-- *** Exception: "This didn't work"+-- >>> import Control.Applicative+-- >>> errorFailWithoutStackTrace (fail "This didn't work" <|> pure "That Worked" :: Fail String)+-- "That Worked"+errorFailWithoutStackTrace :: Fail a -> a+errorFailWithoutStackTrace = F.errorFailWithoutStackTrace++-- | Version of `F.FailT` restricted to `Text`+--+-- Fail monad transformer that plays well with `MonadFail`+type FailT = F.FailT Text++-- | Version of `F.failT` restricted to `Text`+--+-- Monomorphic synonym for `fail`+failT :: Applicative m => Text -> FailT m a+failT = F.failT+{-# INLINE failT #-}++-- | Version of `F.runFailT` restricted to `Text`+runFailT :: Functor m => FailT m a -> m (Either Text a)+runFailT = F.runFailT+{-# INLINE runFailT #-}++-- | Version of `F.runFailLastT` restricted to `Text`+runFailLastT :: Functor m => FailT m a -> m (Either Text a)+runFailLastT = F.runFailLastT+{-# INLINE runFailLastT #-}++-- | Version of `F.runFailAggT` restricted to `Text`+runFailAggT :: FailT m a -> m (Either [Text] a)+runFailAggT = F.runFailAggT+{-# INLINE runFailAggT #-}++-- | Version of `F.hoistFailT` restricted to `Text`+--+-- Change the underlying monad with the hoisting function+hoistFailT :: (forall a. m a -> n a) -> FailT m b -> FailT n b+hoistFailT = F.hoistFailT+{-# INLINE hoistFailT #-}++-- | Version of `F.mapFailT` restricted to `Text`+--+-- Map a function over the underlying representation of the `FailT` monad.+mapFailT :: (m (Either [Text] a) -> n (Either [Text] b)) -> FailT m a -> FailT n b+mapFailT = F.mapFailT+{-# INLINE mapFailT #-}++-- | Version of `F.mapErrorFailT` where resulting type is restricted to `Text`+--+-- Map a function over the error type in the `FailT` monad.+mapErrorFailT :: Functor m => (e -> Text) -> F.FailT e m a -> FailT m a+mapErrorFailT = F.mapErrorFailT+{-# INLINE mapErrorFailT #-}++-- | Version of `F.mapErrorsFail`, where resulting type is restricted to `Text`+--+-- Map a function over the aggregation of errors in the `FailT` monad. Could be used for+-- example for clearing our all of the aggregated error messages:+--+-- >>> runFail (mapErrorsFailT (const [] :: [Text] -> [Text]) $ fail "Something went wrong" >> pure ())+-- Left "No failure reason given"+mapErrorsFailT :: Functor m => ([e] -> [Text]) -> F.FailT e m a -> FailT m a+mapErrorsFailT = F.mapErrorsFailT+{-# INLINE mapErrorsFailT #-}++-- | Version of `F.exceptFailT` restricted to `Text`+exceptFailT :: (HasCallStack, Monad m) => FailT m a -> ExceptT F.FailException m a+exceptFailT = F.exceptFailT+{-# INLINE exceptFailT #-}++-- | Version of `F.throwFailT` restricted to `Text`+throwFailT :: (HasCallStack, MonadThrow m) => FailT m a -> m a+throwFailT = F.throwFailT+{-# INLINE throwFailT #-}
+ tests/Main.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}++module Main where++import Test.Control.Monad.Trans.FailSpec (spec)+import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8)+import Test.Hspec.Runner++config :: Config+#if !(MIN_VERSION_hspec(2,8,0))+config = defaultConfig+#else+config =+  defaultConfig+    { configTimes = True+    , configColorMode = ColorAlways+    }+#endif++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  hSetEncoding stdout utf8+  hspecWith config spec
+ tests/Test/Control/Monad/Trans/FailSpec.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Control.Monad.Trans.FailSpec (spec) where++import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Fail+import Data.Proxy+import Data.Semigroup+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Classes++laws :: Laws -> Spec+laws Laws{lawsTypeclass, lawsProperties} =+  describe lawsTypeclass $ mapM_ (uncurry prop) lawsProperties++instance (Applicative m, Arbitrary e, Arbitrary a) => Arbitrary (FailT e m a) where+  arbitrary = FailT . pure <$> arbitrary++instance (Arbitrary e, Arbitrary1 m, Applicative m) => Arbitrary1 (FailT e m) where+  liftArbitrary gen =+    oneof+      [ FailT . pure . Left <$> arbitrary+      , FailT . pure . Right <$> gen+      ]+  {-# INLINE liftArbitrary #-}++spec :: Spec+spec = do+  describe "FailT" $ do+    prop "runFail" $ \err -> runFail (fail err :: Fail String ()) `shouldBe` Left err+    describe "Instance Laws" $ do+      let px = Proxy :: Proxy (FailT String Maybe (Sum Int))+      let px1 = Proxy :: Proxy (FailT String Maybe)+      mapM_ laws $+        [ eqLaws px+        , ordLaws px+        , showLaws px+        , showReadLaws px+        , monoidLaws px+        , semigroupLaws px+        , alternativeLaws px1+        , applicativeLaws px1+        , foldableLaws px1+        , functorLaws px1+        , monadLaws px1+        , monadZipLaws px1+        , traversableLaws px1+        ]+          ++ extraLaws px+    describe "mtl" $ do+      prop "MonadReader" $ \msg (x :: Int) -> do+        let t :: FailT String (ReaderT Int IO) Int+            t = do+              x' <- ask+              pure $ succ x'+        runReaderT (runFailT t) x `shouldReturn` Right (x + 1)+        runReaderT (runFailT (fail msg >> pure x)) x `shouldReturn` Left msg+      prop "MonadState" $ \msg (x :: Int) -> do+        let t :: FailT String (StateT Int IO) ()+            t = do+              x' <- get+              liftIO (x' `shouldBe` x)+              put (x' + 1)+              modify' succ+        execStateT (runFailT t) x `shouldReturn` (x + 2)+        runStateT (runFailT (fail msg >> modify' succ)) x `shouldReturn` (Left msg, x)++extraLaws :: (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> [Laws]+#if MIN_VERSION_quickcheck_classes(0,6,2)+extraLaws px = [semigroupMonoidLaws px]+#else+extraLaws _px = []+#endif
+ tests/doctests.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}++module Main where++#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ < 900++import Test.DocTest (doctest)++main :: IO ()+main = doctest ["src"]++#else++-- TODO: fix doctest support+main :: IO ()+main =+  putStrLn "\nDoctests are not supported for ghc version 8.2 and prior as well as 8.10 and newer\n"++#endif