diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) YYYY Your Name Here + +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 YOUR NAME HERE 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# `exceptiot` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,6 @@ +# exceptiot + +## 0.0.1.0 + +* [#1](https://github.com/parsonsmatt/exceptiot/pull/1) + * Initial implementation diff --git a/exceptiot.cabal b/exceptiot.cabal new file mode 100644 --- /dev/null +++ b/exceptiot.cabal @@ -0,0 +1,63 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.0. +-- +-- see: https://github.com/sol/hpack + +name: exceptiot +version: 0.0.1.0 +synopsis: ExceptT, but uses IO instead of Either +description: Please see the README on Github at +category: Control +homepage: https://github.com/parsonsmatt/exceptiot#readme +bug-reports: https://github.com/parsonsmatt/exceptiot/issues +author: Matt Parsons +maintainer: parsonsmatt@gmail.com +copyright: 2018 Matt Parsons +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + changelog.md + +source-repository head + type: git + location: https://github.com/parsonsmatt/exceptiot + +library + exposed-modules: + Control.Monad.Except.Catch + Control.Monad.Except.IO + other-modules: + Paths_exceptiot + hs-source-dirs: + src + ghc-options: -Wall -Wcompat + build-depends: + base >=4.13 && <5 + , exceptions + , mtl + , unliftio + , unliftio-core + default-language: Haskell2010 + +test-suite exceptiot-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_exceptiot + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base >=4.13 && <5 + , exceptions + , exceptiot + , hspec + , mtl + , unliftio + , unliftio-core + default-language: Haskell2010 diff --git a/src/Control/Monad/Except/Catch.hs b/src/Control/Monad/Except/Catch.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Except/Catch.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Control.Monad.Except.Catch + ( ExceptCatchT (..) + , runExceptCatchT + , module Control.Monad.Error.Class + , modifyError + ) where + +import Control.Applicative +import Control.Monad.Catch +import Control.Monad.Error.Class hiding (modifyError) +import qualified Control.Monad.Except as Except +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer + +-- | This type is useful for translating a 'MonadError' constraint into +-- 'MonadCatch'. This type does not have an 'Either' return, which means we can +-- provide a 'MonadUnliftIO' instance. +-- +-- @since 0.1.0.0 +newtype ExceptCatchT e m a = ExceptCatchT { unsafeRunExceptCatchT :: m a } + deriving newtype + ( Functor, Applicative, Monad, MonadIO, MonadPlus, Alternative + , Semigroup, Monoid, MonadUnliftIO, MonadReader r, MonadState s + , MonadWriter w , MonadFix, MonadFail, MonadThrow, MonadCatch, MonadMask + ) + +-- | +-- +-- @since 0.1.0.0 +instance (MonadCatch m, Exception e) => MonadError e (ExceptCatchT e m) where + throwError = throwM + catchError = catch + +-- | Run an 'ExceptCatchT' action. This will catch any thrown @e@ exceptions, +-- regardless of whether you used 'throwM' or 'throwError'. +-- +-- Any exception that is not mentioned in @e@ will be thrown - this does not +-- catch all exceptions! +-- +-- @since 0.1.0.0 +runExceptCatchT :: (Exception e, MonadCatch m) => ExceptCatchT e m a -> m (Either e a) +runExceptCatchT = try . unsafeRunExceptCatchT + +-- | Like 'Except.modifyError', but it selects the 'ExceptCatchT' instance for 'IO' +-- exceptions instead of the 'ExceptT' instance with an 'Either' error. +-- +-- @since 0.1.0.0 +modifyError + :: (Exception e, MonadCatch m, MonadError e' m) + => (e -> e') -> ExceptCatchT e m a -> m a +modifyError f action = + runExceptCatchT action >>= either (throwError . f) pure diff --git a/src/Control/Monad/Except/IO.hs b/src/Control/Monad/Except/IO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Except/IO.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Control.Monad.Except.IO + ( ExceptIOT (..) + , runExceptIOT + , module Control.Monad.Error.Class + , modifyError + ) where + +import Control.Applicative +import Control.Monad.Catch hiding (catch, try) +import Control.Monad.Error.Class hiding (modifyError) +import qualified Control.Monad.Except as Except +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import UnliftIO + +-- | This type is useful for providing a 'MonadError' constraint to an 'IO' +-- action for a given type. It can replace 'ExceptT'. +-- +-- Note that 'catchError' will use the behavior from "UnliftIO" - so catch won't +-- catch an asynchronous exception. +-- +-- @since 0.1.0.0 +newtype ExceptIOT e m a = ExceptIOT { unsafeRunExceptIOT :: m a } + deriving newtype + ( Functor, Applicative, Monad, MonadIO, MonadPlus, Alternative + , Semigroup, Monoid, MonadUnliftIO, MonadReader r, MonadState s + , MonadWriter w, MonadFix, MonadFail, MonadThrow, MonadCatch, MonadMask + ) + +-- | +-- +-- @since 0.1.0.0 +instance (MonadUnliftIO m, Exception e) => MonadError e (ExceptIOT e m) where + throwError = throwIO + catchError = catch + +-- | Run an 'ExceptIOT' action. This catches the thrown exception, but only if +-- it is the @e@ that the type mentions. All other exceptions will remain +-- uncaught. +-- +-- @since 0.1.0.0 +runExceptIOT :: (Exception e, MonadUnliftIO m) => ExceptIOT e m a -> m (Either e a) +runExceptIOT = try . unsafeRunExceptIOT + +-- | Like 'Except.modifyError', but it selects the 'ExceptIOT' instance for 'IO' +-- exceptions instead of the 'ExceptT' instance with an 'Either' error. +-- +-- @since 0.1.0.0 +modifyError + :: (Exception e, MonadUnliftIO m, MonadError e' m) + => (e -> e') -> ExceptIOT e m a -> m a +modifyError f action = + runExceptIOT action >>= either (throwError . f) pure diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}