From 5ce46080ee159fc76fdaa837af8d0c50838440ae Mon Sep 17 00:00:00 2001 From: JackKelly-Bellroy Date: Fri, 3 May 2024 09:16:56 +1000 Subject: [PATCH 1/7] Remove legacy deps and support for ancient mtl (`mtl-2.1` is from 2012.) --- hoist-error.cabal | 3 +-- src/Control/Monad/Error/Hoist.hs | 24 ------------------------ 2 files changed, 1 insertion(+), 26 deletions(-) diff --git a/hoist-error.cabal b/hoist-error.cabal index 4a86a07..763604b 100644 --- a/hoist-error.cabal +++ b/hoist-error.cabal @@ -34,8 +34,7 @@ source-repository head library exposed-modules: Control.Monad.Error.Hoist build-depends: base >=4.7 && <4.18 - , mtl >=2.1 && <2.3 - , either >=4 && <6 + , mtl >=2.2 && <2.3 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Control/Monad/Error/Hoist.hs b/src/Control/Monad/Error/Hoist.hs index e4e2518..5bec84c 100644 --- a/src/Control/Monad/Error/Hoist.hs +++ b/src/Control/Monad/Error/Hoist.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} @@ -46,18 +45,8 @@ import Control.Monad.Error.Class (MonadError (..)) import Data.Either (Either, either) -#if MIN_VERSION_mtl(2,2,2) import Control.Monad.Except (Except, ExceptT, runExcept, runExceptT) -#else -import Control.Monad.Error (Error, ErrorT, runErrorT) -#endif - -#if MIN_VERSION_either(5,0,0) --- Control.Monad.Trans.Either was removed from @either@ in version 5. -#else -import Control.Monad.Trans.Either (EitherT, eitherT, runEitherT) -#endif -- | A tricky class for easily hoisting errors out of partiality types (e.g. -- 'Maybe', @'Either' e@) into a monad. The parameter @e@ represents the error @@ -85,24 +74,11 @@ instance MonadError e m => HoistError m Maybe () e where instance MonadError e' m => HoistError m (Either e) e e' where hoistError f = either (throwError . f) return -#if MIN_VERSION_either(5,0,0) --- Control.Monad.Trans.Either was removed from @either@ in version 5. -#else -instance (m ~ n, MonadError e' m) => HoistError m (EitherT e n) e e' where - hoistError f = eitherT (throwError . f) return -#endif - -#if MIN_VERSION_mtl(2,2,2) instance MonadError e' m => HoistError m (Except e) e e' where hoistError f = either (throwError . f) return . runExcept instance MonadError e' m => HoistError m (ExceptT e m) e e' where hoistError f = either (throwError . f) return <=< runExceptT -#else --- 'ErrorT' was renamed to 'ExceptT' in mtl 2.2.2 -instance MonadError e' m => HoistError m (ErrorT e m) e e' where - hoistError f = either (throwError . f) return <=< runErrorT -#endif -- | A version of 'hoistError' that operates on values already in the monad. -- From e830ff12ccdb7c6b0e120a4f04f442e2b902cc6d Mon Sep 17 00:00:00 2001 From: JackKelly-Bellroy Date: Fri, 3 May 2024 10:54:11 +1000 Subject: [PATCH 2/7] Rewrite module in terms of `PluckError` and improve docs --- src/Control/Monad/Error/Hoist.hs | 117 ++++++++++++++++++------------- 1 file changed, 68 insertions(+), 49 deletions(-) diff --git a/src/Control/Monad/Error/Hoist.hs b/src/Control/Monad/Error/Hoist.hs index 5bec84c..ff253c5 100644 --- a/src/Control/Monad/Error/Hoist.hs +++ b/src/Control/Monad/Error/Hoist.hs @@ -1,43 +1,49 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} --- | 'HoistError' extends 'MonadError' with 'hoistError', which enables lifting --- of partiality types such as 'Maybe' and @'Either' e@ into the monad. +-- | This module provides helper functions for lifting partiality types into +-- error-carrying monads like 'ExceptT'. -- -- For example, consider the following @App@ monad that may throw @BadPacket@ -- errors: -- -- @ --- data AppError = BadPacket 'String' +-- data AppError = BadPacket 'Text' -- -- newtype App a = App ('EitherT' AppError 'IO') a -- deriving ('Functor', 'Applicative', 'Monad', 'MonadError' AppError, 'MonadIO') -- @ -- --- We may have an existing function that parses a 'String' into a @'Maybe' Packet@ +-- We may have an existing function that attempts to parse a 'ByteString': -- -- @ --- parsePacket :: 'String' -> 'Maybe' Packet +-- parsePacket :: 'ByteString' -> 'Either' 'Text' Packet -- @ -- --- which can be lifted into the @App@ monad with 'hoistError' +-- We can be lift this error into the @App@ monad using @('<%?>')@: -- -- @ --- appParsePacket :: 'String' -> 'App' Packet --- appParsePacket s = 'hoistError' (\\() -> BadPacket "no parse") (parsePacket s) +-- appParsePacket :: 'ByteString' -> 'App' Packet +-- appParsePacket s = parsePacket s \<%?\> BadPacket -- @ -- --- Similar instances exist for @'Either' e@ and @'EitherT' e m@. +-- Instances also exist for extracting errors from other partiality types +-- like @'Either' e@ and @'ExceptT' e m@. module Control.Monad.Error.Hoist - ( HoistError(..) + ( hoistError , hoistErrorM + -- ** Operators + -- $mnemonics , (<%?>) , (<%!?>) , () , () + -- * Helper class + , PluckError(..) ) where import Control.Monad ((<=<)) @@ -48,37 +54,20 @@ import Data.Either (Either, either) import Control.Monad.Except (Except, ExceptT, runExcept, runExceptT) --- | A tricky class for easily hoisting errors out of partiality types (e.g. --- 'Maybe', @'Either' e@) into a monad. The parameter @e@ represents the error --- information carried by the partiality type @t@, and @e'@ represents the type --- of error expected in the monad @m@. +-- | Given a conversion from the error in @t a@ to @e'@, we can hoist the +-- computation into @m@. -- -class Monad m => HoistError m t e e' | t -> e where - - -- | Given a conversion from the error in @t a@ to @e'@, we can hoist the - -- computation into @m@. - -- - -- @ - -- 'hoistError' :: 'MonadError' e m -> (() -> e) -> 'Maybe' a -> m a - -- 'hoistError' :: 'MonadError' e m -> (a -> e) -> 'Either' a b -> m b - -- 'hoistError' :: 'MonadError' e m -> (a -> e) -> 'ExceptT' a m b -> m b - -- @ - hoistError - :: (e -> e') - -> t a - -> m a - -instance MonadError e m => HoistError m Maybe () e where - hoistError f = maybe (throwError $ f ()) return - -instance MonadError e' m => HoistError m (Either e) e e' where - hoistError f = either (throwError . f) return - -instance MonadError e' m => HoistError m (Except e) e e' where - hoistError f = either (throwError . f) return . runExcept - -instance MonadError e' m => HoistError m (ExceptT e m) e e' where - hoistError f = either (throwError . f) return <=< runExceptT +-- @ +-- 'hoistError' :: 'MonadError' e m -> (() -> e) -> 'Maybe' a -> m a +-- 'hoistError' :: 'MonadError' e m -> (a -> e) -> 'Either' a b -> m b +-- 'hoistError' :: 'MonadError' e m -> (a -> e) -> 'ExceptT' a m b -> m b +-- @ +hoistError + :: (PluckError e t m, MonadError e' m) + => (e -> e') + -> t a + -> m a +hoistError f t = inspectError t >>= either (throwError . f) pure -- | A version of 'hoistError' that operates on values already in the monad. -- @@ -88,13 +77,27 @@ instance MonadError e' m => HoistError m (ExceptT e m) e e' where -- 'hoistErrorM' :: 'MonadError' e m => (a -> e) -> 'ExceptT' a m b -> 'ExceptT' a m b -- @ hoistErrorM - :: HoistError m t e e' + :: (PluckError e t m, MonadError e' m) => (e -> e') -> m (t a) -> m a -hoistErrorM e m = do - x <- m - hoistError e x +hoistErrorM e m = m >>= hoistError e + +-- $mnemonics +-- +-- The operators in this package are named according to a scheme: +-- +-- * @('')@ is the simplest error-handling function: it replaces +-- any error with its second argument. +-- +-- * The additional @!@ in @('')@ and @('<%!?>')@ means the +-- operator handles values that are already "in a monad". +-- +-- * The additional @%@ in @('<%?>')@ and @('<%!?>')@ means the +-- operator takes a function argument, which is applies to the error +-- from the partiality type. (The mnemonic is that @%@ sometimes +-- means "mod", and we use "mod" as a shorthand for "modify". It's a +-- long bow, but @lens@ uses the same mnemonic.) -- | A flipped synonym for 'hoistError'. -- @@ -104,7 +107,7 @@ hoistErrorM e m = do -- ('<%?>') :: 'MonadError' e m => 'ExceptT' a m b -> (a -> e) -> 'ExceptT' a m b -- @ (<%?>) - :: HoistError m t e e' + :: (PluckError e t m, MonadError e' m) => t a -> (e -> e') -> m a @@ -121,7 +124,7 @@ infixl 8 <%?> -- ('<%!?>') :: 'MonadError' e m => 'ExceptT' a m b -> (a -> e) -> 'ExceptT' a m b -- @ (<%!?>) - :: HoistError m t e e' + :: (PluckError e t m, MonadError e' m) => m (t a) -> (e -> e') -> m a @@ -139,7 +142,7 @@ infixl 8 <%!?> -- ('') :: 'MonadError' e m => 'ExceptT' a m b -> e -> 'ExceptT' a m b -- @ () - :: HoistError m t e e' + :: (PluckError e t m, MonadError e' m) => t a -> e' -> m a @@ -156,7 +159,7 @@ infixl 8 -- ('') :: 'MonadError' e m => 'ExceptT' a m b -> e -> 'ExceptT' a m b -- @ () - :: HoistError m t e e' + :: (PluckError e t m, MonadError e' m) => m (t a) -> e' -> m a @@ -166,3 +169,19 @@ m e = do infixl 8 {-# INLINE () #-} + +-- | A class for plucking an error @e@ out of a partiality type @t@. +class PluckError e t m | t -> e where + inspectError :: t a -> m (Either e a) + +instance (Applicative m, e ~ ()) => PluckError e Maybe m where + inspectError = pure . maybe (Left ()) Right + +instance Applicative m => PluckError e (Either e) m where + inspectError = pure + +instance PluckError e (ExceptT e m) m where + inspectError = runExceptT + +instance Applicative m => PluckError e (Except e) m where + inspectError = pure . runExcept From d2c7945709ded4ffd84138e18f1e6354b4ba06c5 Mon Sep 17 00:00:00 2001 From: JackKelly-Bellroy Date: Fri, 3 May 2024 11:24:47 +1000 Subject: [PATCH 3/7] Introduce Control.Monad.Fail.Hoist --- changelog.md | 8 ++ hoist-error.cabal | 18 ++-- src/Control/Monad/Fail/Hoist.hs | 140 ++++++++++++++++++++++++++++++++ 3 files changed, 154 insertions(+), 12 deletions(-) create mode 100644 src/Control/Monad/Fail/Hoist.hs diff --git a/changelog.md b/changelog.md index 63f99e1..15967af 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,11 @@ +0.3.0.0 + +* Replaced the `HoistError` typeclass, which is about monads, with a + simpler `PluckError` typeclass that is about extracting errors from + values. +* Introduced a parallel `Control.Monad.Fail.Hoist` module, for + hoisting error messages into `MonadFail`. + 0.2.1.0 * Removed unicode syntax and variables diff --git a/hoist-error.cabal b/hoist-error.cabal index 763604b..060a482 100644 --- a/hoist-error.cabal +++ b/hoist-error.cabal @@ -1,5 +1,5 @@ name: hoist-error -version: 0.2.2.0 +version: 0.3.0.0 synopsis: Some convenience facilities for hoisting errors into a monad description: Provides a typeclass and useful combinators for hoisting errors into a monad. license: MIT @@ -13,27 +13,21 @@ cabal-version: >=1.10 extra-source-files: changelog.md -tested-with: GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 +tested-with: GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.1 , GHC == 9.2.7 , GHC == 9.4.5 - - source-repository head type: git location: https://github.com/alephcloud/hs-hoist-error.git library - exposed-modules: Control.Monad.Error.Hoist - build-depends: base >=4.7 && <4.18 + exposed-modules: + Control.Monad.Error.Hoist + Control.Monad.Fail.Hoist + build-depends: base >=4.13 && <4.18 , mtl >=2.2 && <2.3 hs-source-dirs: src diff --git a/src/Control/Monad/Fail/Hoist.hs b/src/Control/Monad/Fail/Hoist.hs new file mode 100644 index 0000000..a4dd9e9 --- /dev/null +++ b/src/Control/Monad/Fail/Hoist.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides helpers for converting partiality types into +-- 'MonadFail' computations. +-- +-- 'MonadFail''s purpose is to handle pattern-match failures in +-- @do@-expressions, and not to be a general-purpose error-handling +-- mechanism. Despite this, some libraries use it as one, and this +-- module can help you report errors via 'MonadFail'. +-- +-- The operator mnemonics are the same as in +-- "Control.Monad.Error.Hoist", but with @#@ in place of @?@. You can +-- imagine a hastily-written @F@ looking kinda-sorta like a @#@, if it +-- helps. + +module Control.Monad.Fail.Hoist + ( hoistFail + , hoistFail' + , hoistFailM + , hoistFailM' + -- ** Operators + , (<%#>) + , (<%!#>) + , (<#>) + , () + ) where + +import Control.Monad.Error.Hoist (PluckError(..)) + +-- | Given a conversion from the error in @t a@ to @String@, we can hoist the +-- computation into @m@. +-- +-- @ +-- 'hoistFail' :: 'MonadFail' m => (() -> String) -> 'Maybe' a -> m a +-- 'hoistFail' :: 'MonadFail' m => (a -> String) -> 'Either' a b -> m b +-- @ +hoistFail + :: (PluckError e t m, MonadFail m) + => (e -> String) + -> t a + -> m a +hoistFail f t = inspectError t >>= either (fail . f) pure + +-- | Hoist computations whose error type is already 'String'. +hoistFail' :: (PluckError String t m, MonadFail m) => t a -> m a +hoistFail' = hoistFail id + +-- | A version of 'hoistFail' that operates on values already in the monad. +-- +-- @ +-- 'hoistFailM' :: 'MonadFail' m => (() -> String) -> m ('Maybe' a) -> m a +-- 'hoistFailM' :: 'MonadFail' m => (a -> String) -> m ('Either' a b) -> m b +-- 'hoistFailM' :: 'MonadFail' m => (a -> String) -> 'ExceptT' a m b -> 'ExceptT' a m b +-- @ +hoistFailM + :: (PluckError e t m, MonadFail m) + => (e -> String) + -> m (t a) + -> m a +hoistFailM f m = m >>= hoistFail f + +-- | A version of 'hoistFail'' that operates on values already in the monad. +-- +-- @ +-- 'hoistFailM'' :: 'MonadFail' m => m ('Maybe' a) -> m a +-- 'hoistFailM'' :: 'MonadFail' m => m ('Either' a b) -> m b +-- 'hoistFailM'' :: 'MonadFail' m => 'ExceptT' a m b -> 'ExceptT' a m b +-- @ +hoistFailM' + :: (PluckError String t m, MonadFail m) + => m (t a) + -> m a +hoistFailM' = hoistFailM id + +-- | A flipped synonym for 'hoistFail'. Mnemonic: @#@ looks a bit like @F@ +-- +-- @ +-- ('<%#>') :: 'MonadFail' m => 'Maybe' a -> (() -> e) -> m a +-- ('<%#>') :: 'MonadFail' m => 'Either' a b -> (a -> e) -> m b +-- @ +(<%#>) + :: (PluckError e t m, MonadFail m) + => t a + -> (e -> String) + -> m a +(<%#>) = flip hoistFail + +infixl 8 <%#> +{-# INLINE (<%#>) #-} + +-- | A flipped synonym for 'hoistFailM'. +-- +-- @ +-- ('<%!#>') :: 'MonadError' e m => m ('Maybe' a) -> (() -> e) -> m a +-- ('<%!#>') :: 'MonadError' e m => m ('Either' a b) -> (a -> e) -> m b +-- ('<%!#>') :: 'MonadError' e m => 'ExceptT' a m b -> (a -> e) -> 'ExceptT' a m b +-- @ +(<%!#>) + :: (PluckError e t m, MonadFail m) + => m (t a) + -> (e -> String) + -> m a +(<%!#>) = flip hoistFailM + +infixl 8 <%!#> +{-# INLINE (<%!#>) #-} + +-- | A version of '<%#>' that ignores the error in @t a@ and fails +-- with a new one. +-- +-- @ +-- ('<#>') :: 'MonadFail' m => 'Maybe' a -> String -> m a +-- ('<#>') :: 'MonadFail' m => 'Either' a b -> String -> m b +-- @ +(<#>) + :: (PluckError e t m, MonadFail m) + => t a + -> String + -> m a +m <#> e = m <%#> const e + +infixl 8 <#> +{-# INLINE (<#>) #-} + +-- | A version of '<#>' that operates on values already in the monad. +-- +-- @ +-- ('') :: 'MonadFail m => m ('Maybe' a) -> String -> m a +-- ('') :: 'MonadFail m => m ('Either' a b) -> String -> m b +-- ('') :: 'MonadFail m => 'ExceptT' a m b -> String -> 'ExceptT' a m b +-- @ +() + :: (PluckError e t m, MonadFail m) + => m (t a) + -> String + -> m a +m e = m >>= hoistFail (const e) + +infixl 8 +{-# INLINE () #-} From 934836d54ee0b4518ec6457e96fc383ccc37797e Mon Sep 17 00:00:00 2001 From: JackKelly-Bellroy Date: Fri, 3 May 2024 11:35:54 +1000 Subject: [PATCH 4/7] Support GHC 9.6 and 9.8 --- hoist-error.cabal | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/hoist-error.cabal b/hoist-error.cabal index 060a482..172073f 100644 --- a/hoist-error.cabal +++ b/hoist-error.cabal @@ -18,6 +18,8 @@ tested-with: GHC == 8.8.4 , GHC == 9.0.1 , GHC == 9.2.7 , GHC == 9.4.5 + , GHC == 9.6.4 + , GHC == 9.8.2 source-repository head type: git @@ -27,8 +29,8 @@ library exposed-modules: Control.Monad.Error.Hoist Control.Monad.Fail.Hoist - build-depends: base >=4.13 && <4.18 - , mtl >=2.2 && <2.3 + build-depends: base >=4.13 && <4.20 + , mtl >=2.2 && <2.4 hs-source-dirs: src default-language: Haskell2010 From 43f9630a543ae0507c286c1c77a641a324866f94 Mon Sep 17 00:00:00 2001 From: JackKelly-Bellroy Date: Fri, 3 May 2024 11:37:05 +1000 Subject: [PATCH 5/7] Regenerate CI --- .github/workflows/haskell-ci.yml | 68 ++++++++++++-------------------- 1 file changed, 25 insertions(+), 43 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 1c733e2..11d44fe 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.16.3 +# version: 0.18.1 # -# REGENDATA ("0.16.3",["github","hoist-error.cabal"]) +# REGENDATA ("0.18.1",["github","hoist-error.cabal"]) # name: Haskell-CI on: @@ -28,6 +28,16 @@ jobs: strategy: matrix: include: + - compiler: ghc-9.8.2 + compilerKind: ghc + compilerVersion: 9.8.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.6.4 + compilerKind: ghc + compilerVersion: 9.6.4 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.4.5 compilerKind: ghc compilerVersion: 9.4.5 @@ -53,36 +63,6 @@ jobs: compilerVersion: 8.8.4 setup-method: hvr-ppa allow-failure: false - - compiler: ghc-8.6.5 - compilerKind: ghc - compilerVersion: 8.6.5 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.4.4 - compilerKind: ghc - compilerVersion: 8.4.4 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.2.2 - compilerKind: ghc - compilerVersion: 8.2.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.0.2 - compilerKind: ghc - compilerVersion: 8.0.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.10.3 - compilerKind: ghc - compilerVersion: 7.10.3 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.8.4 - compilerKind: ghc - compilerVersion: 7.8.4 - setup-method: hvr-ppa - allow-failure: false fail-fast: false steps: - name: apt @@ -91,18 +71,18 @@ jobs: apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 if [ "${{ matrix.setup-method }}" = ghcup ]; then mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) else apt-add-repository -y 'ppa:hvr/ghc' apt-get update apt-get install -y "$HCNAME" mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) fi env: HCKIND: ${{ matrix.compilerKind }} @@ -116,17 +96,19 @@ jobs: echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER if [ "${{ matrix.setup-method }}" = ghcup ]; then - HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" - echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" else HC=$HCDIR/bin/$HCKIND echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" fi HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') @@ -209,8 +191,8 @@ jobs: touch cabal.project touch cabal.project.local echo "packages: ${PKGDIR_hoist_error}" >> cabal.project - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package hoist-error" >> cabal.project ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + echo "package hoist-error" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local From 30818287392cd026c0c2b01f1befc5ed7751456f Mon Sep 17 00:00:00 2001 From: JackKelly-Bellroy Date: Fri, 3 May 2024 11:42:32 +1000 Subject: [PATCH 6/7] Fix status badge --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 2866312..8fb77f0 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ ## Hoist Error -[![Build Status](https://travis-ci.org/qfpl/hs-hoist-error.svg?branch=master)](https://travis-ci.org/qfpl/hs-hoist-error) +[![Haskell-CI](https://github.com/qfpl/hs-hoist-error/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/qfpl/hs-hoist-error/actions/workflows/haskell-ci.yml) A typeclass and some combinators to aid in the lifting of errors into your preferred context. From 89ff5a811f6b05bf821ce8828ce47efda0ddbbbc Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Fri, 3 May 2024 15:28:11 +1000 Subject: [PATCH 7/7] Add `foldError` function to class `PluckError` --- src/Control/Monad/Error/Hoist.hs | 27 ++++++++++++++++++++------- src/Control/Monad/Fail/Hoist.hs | 2 +- 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/Control/Monad/Error/Hoist.hs b/src/Control/Monad/Error/Hoist.hs index ff253c5..3ab7e5a 100644 --- a/src/Control/Monad/Error/Hoist.hs +++ b/src/Control/Monad/Error/Hoist.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} @@ -67,7 +68,7 @@ hoistError => (e -> e') -> t a -> m a -hoistError f t = inspectError t >>= either (throwError . f) pure +hoistError f = foldError (throwError . f) pure -- | A version of 'hoistError' that operates on values already in the monad. -- @@ -172,16 +173,28 @@ infixl 8 -- | A class for plucking an error @e@ out of a partiality type @t@. class PluckError e t m | t -> e where - inspectError :: t a -> m (Either e a) + pluckError :: t a -> m (Either e a) + default pluckError :: Applicative m => t a -> m (Either e a) + pluckError = foldError (pure . Left) (pure . Right) + + foldError :: (e -> m r) -> (a -> m r) -> t a -> m r + default foldError :: Monad m => (e -> m r) -> (a -> m r) -> t a -> m r + foldError f g = either f g <=< pluckError + + {-# MINIMAL pluckError | foldError #-} instance (Applicative m, e ~ ()) => PluckError e Maybe m where - inspectError = pure . maybe (Left ()) Right + pluckError = pure . maybe (Left ()) Right + foldError f = maybe (f ()) instance Applicative m => PluckError e (Either e) m where - inspectError = pure + pluckError = pure + foldError = either -instance PluckError e (ExceptT e m) m where - inspectError = runExceptT +instance Monad m => PluckError e (ExceptT e m) m where + pluckError = runExceptT + foldError f g = either f g <=< runExceptT instance Applicative m => PluckError e (Except e) m where - inspectError = pure . runExcept + pluckError = pure . runExcept + foldError f g = either f g . runExcept diff --git a/src/Control/Monad/Fail/Hoist.hs b/src/Control/Monad/Fail/Hoist.hs index a4dd9e9..95222b4 100644 --- a/src/Control/Monad/Fail/Hoist.hs +++ b/src/Control/Monad/Fail/Hoist.hs @@ -39,7 +39,7 @@ hoistFail => (e -> String) -> t a -> m a -hoistFail f t = inspectError t >>= either (fail . f) pure +hoistFail f = foldError (fail . f) pure -- | Hoist computations whose error type is already 'String'. hoistFail' :: (PluckError String t m, MonadFail m) => t a -> m a