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 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. 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 4a86a07..172073f 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,29 +13,24 @@ 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 - - + , GHC == 9.6.4 + , GHC == 9.8.2 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 - , mtl >=2.1 && <2.3 - , either >=4 && <6 + exposed-modules: + Control.Monad.Error.Hoist + Control.Monad.Fail.Hoist + build-depends: base >=4.13 && <4.20 + , mtl >=2.2 && <2.4 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..3ab7e5a 100644 --- a/src/Control/Monad/Error/Hoist.hs +++ b/src/Control/Monad/Error/Hoist.hs @@ -1,44 +1,50 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} {-# 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 ((<=<)) @@ -46,63 +52,23 @@ 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 --- information carried by the partiality type @t@, and @e'@ represents the type --- of error expected in the monad @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 - -#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 + +-- | 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 + :: (PluckError e t m, MonadError e' m) + => (e -> e') + -> t a + -> m a +hoistError f = foldError (throwError . f) pure -- | A version of 'hoistError' that operates on values already in the monad. -- @@ -112,13 +78,27 @@ instance MonadError e' m => HoistError m (ErrorT 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'. -- @@ -128,7 +108,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 @@ -145,7 +125,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 @@ -163,7 +143,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 @@ -180,7 +160,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 @@ -190,3 +170,31 @@ 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 + 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 + pluckError = pure . maybe (Left ()) Right + foldError f = maybe (f ()) + +instance Applicative m => PluckError e (Either e) m where + pluckError = pure + foldError = either + +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 + 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 new file mode 100644 index 0000000..95222b4 --- /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 = foldError (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 () #-}