diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# exitcode + +Monad transformer for exit codes + +![System-F](https://logo.systemf.com.au/systemf-450x450.jpg) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,8 @@ -import Distribution.Simple +{-# OPTIONS_GHC -Wall -Werror #-} + +module Main (main) where + +import Distribution.Simple (defaultMain) + +main :: IO () main = defaultMain diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +module Main (main) where + +import Control.Exitcode (Exitcode', mkExitFailure1', mkExitSuccess', runExitcode) +import Data.Functor.Identity (runIdentity) +import Test.Tasty.Bench (bench, bgroup, defaultMain, whnf) + +n :: Int +n = 1000 + +bindChain :: Int -> Exitcode' () Int +bindChain depth = iterate (\acc -> acc >>= \x -> mkExitSuccess' (x + 1)) (mkExitSuccess' 0) !! depth +{-# NOINLINE bindChain #-} + +failShortCircuit :: Int -> Exitcode' () Int +failShortCircuit depth = iterate (\acc -> acc >>= \x -> mkExitSuccess' (x + 1)) (mkExitFailure1' () >> mkExitSuccess' 0) !! depth +{-# NOINLINE failShortCircuit #-} + +failPropagation :: Int -> Exitcode' Int Int +failPropagation depth = iterate (\acc -> acc >>= \_ -> mkExitFailure1' 0) (mkExitSuccess' 0) !! depth +{-# NOINLINE failPropagation #-} + +main :: IO () +main = + defaultMain + [ bgroup + "Exitcode" + [ bgroup + "bind" + [ bench "success-chain" $ whnf (runIdentity . runExitcode . bindChain) n, + bench "fail-short-circuit" $ whnf (runIdentity . runExitcode . failShortCircuit) n, + bench "fail-propagation" $ whnf (runIdentity . runExitcode . failPropagation) n + ] + ] + ] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,22 @@ +0.3.0.0 + +* Replace `Int` exit code representation with `NotZero` from the `natural` package, making it impossible to construct a failure with exit code 0 +* Introduce `ExitcodeBifunctor` newtype enabling `Bifunctor`, `Bifoldable`, and `Bitraversable` instances +* Add `bimapExitcode` for mapping both error and success values +* Add `toExitCode` and `toExitCode'` as inverses of `fromExitCode`/`fromExitCode'` +* Add `maybeExitcode` and `maybeExitcode'` for extracting exit code as `Maybe NotZero` +* Add `embedExitcode` for embedding natural transformations +* Add `_ExitFailureCode`, `_ExitFailureCode'`, `_ExitFailureValue`, `_ExitFailureValue'` optics +* Add four-level classy optics hierarchy (`Get`/`Has`/`Review`/`As`) for all `Control.Process` types +* Add `_UseHandle` prism to `AsStdStream` +* Add `streams` and `streams1` traversals for `CreateProcess` +* Remove `mapExitcode` (subsumed by `ExitcodeBifunctor`) +* Rename `ExitcodeT` to `Exitcode`, `ExitcodeT1` to removed +* Add `NFData` and `NFData1` instances +* Add fusion RULES for `exitcodeMap` and `exitcodeFoldMap` +* Add comprehensive doctest coverage (291 tests) +* Add benchmarks + 0.2.0.0 * some API updates diff --git a/exitcode.cabal b/exitcode.cabal --- a/exitcode.cabal +++ b/exitcode.cabal @@ -1,31 +1,38 @@ --- documentation, see http://haskell.org/cabal/users-guide/ - +cabal-version: 2.4 name: exitcode -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Monad transformer for exit codes description: Monad transformer for exit codes . <> -license: BSD3 +license: BSD-3-Clause license-file: LICENCE author: Queensland Functional Programming Lab maintainer: Tony Morris copyright: Copyright (C) 2019-2025 Tony Morris category: Control build-type: Simple -extra-source-files: changelog.md -cabal-version: >=1.10 +extra-doc-files: changelog.md + , README.md homepage: https://gitlab.com/system-f/code/exitcode bug-reports: https://gitlab.com/system-f/code/exitcode/issues -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1, GHC == 9.4.8, GHC == 9.6.7 +tested-with: GHC == 9.6.7 +flag dev + description: Enable development warnings (-Werror, -O2 for benchmarks) + manual: True + default: False + source-repository head type: git location: git@gitlab.com:system-f/code/exitcode.git library exposed-modules: Control.Exitcode + Control.Exitcode.Exitcode + Control.Exitcode.Optics + Control.Process.Process Control.Process Control.Process.CmdSpec Control.Process.CreateProcess @@ -33,41 +40,48 @@ Control.Process.GroupID Control.Process.Handle Control.Process.Pid - Control.Process.Process Control.Process.ProcessHandle Control.Process.StdStream Control.Process.UserID build-depends: base >= 4.8 && < 6 , bifunctors >= 5 && < 6 + , comonad >= 5 && < 6 + , deepseq >= 1.4 && < 2 , filepath >= 1.4 && < 2 , lens >= 4.15 && < 6 , mtl >= 2.2 && < 3 , process >= 1.6.12.0 && < 2 , semigroupoids >= 5.1 && < 7 - , semigroups >= 0.16 && < 1 - , transformers >= 0.5.0 && < 1 + , transformers >= 0.5 && < 1 + , natural >= 0.5.0.1 && < 1 + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -test-suite tests - build-depends: QuickCheck >= 2.9.2 && < 2.13 - , base >= 4.8 && < 6 - , bifunctors >= 5 && < 6 - , checkers >= 0.4.6 && < 0.5 - , exitcode - , hedgehog >= 0.5 && < 0.7 - , lens >= 4.15 && < 6 - , mtl >= 2.2 && < 2.3 - , semigroupoids >= 5.1 && < 5.4 - , tasty >= 0.11 && < 1.3 - , tasty-hunit >= 0.9 && < 0.11 - , tasty-hedgehog >= 0.1 && < 0.3 - , tasty-quickcheck >= 0.8.4 && < 0.11 - , transformers >= 0.5.0 && < 5.5 - type: exitcode-stdio-1.0 - main-is: Tests.hs - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall + if flag(dev) + ghc-options: -Werror + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , process >= 1 && < 2 + build-tool-depends: doctest:doctest >= 0.22 && < 1 + default-language: Haskell2010 + ghc-options: -Wall + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , tasty-bench >= 0.3 && < 1 + , exitcode + default-language: Haskell2010 + ghc-options: -Wall + + if flag(dev) + ghc-options: -Werror -O2 diff --git a/src/Control/Exitcode.hs b/src/Control/Exitcode.hs --- a/src/Control/Exitcode.hs +++ b/src/Control/Exitcode.hs @@ -1,816 +1,11 @@ -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} - -module Control.Exitcode ( --- * Types - ExitcodeT -, Exitcode -, ExitcodeT0 -, Exitcode0 -, ExitcodeT1 -, Exitcode1 --- * Construction -, exitsuccess -, exitsuccess0 -, exitfailure -, exitfailure0 -, exitfailureNeg1 -, exitcodeValue -, exitcodeValue0 -, fromExitCode -, fromExitCode' -, liftExitcode -, liftExitcodeFailure -, liftExitcodeFailure0 -, liftExitFailureNeg1 -, hoistExitcode -, embedExitcode -, exitcode1 --- * Extraction -, runExitcodeT -, maybeExitcodeT -, runExitcode -, maybeExitcode -, runExitcodeT1 -, runExitcode1 --- * Exceptions -, tryExitcode -, liftTryExitcode --- * Optics -, exitCode -, _ExitcodeInt -, _ExitcodeInt' -, _ExitFailure -, _ExitFailureError -, _ExitSuccess -, _Exitcode1 -) where - - -import Control.Applicative - ( Applicative((<*>), pure, liftA2) ) -import Control.Category ( Category((.)) ) -import Control.Exception ( try, Exception ) -import Control.Lens - ( preview, - view, - iso, - _Left, - prism, - over, - Field1(_1), - Field2(_2), - Iso, - Lens, - Prism, - Traversal, - Traversal' ) -import Control.Monad ( join, Monad(return, (>>=)) ) -import Control.Monad.Cont.Class ( MonadCont(..) ) -import Control.Monad.Error.Class ( MonadError(..) ) -import Control.Monad.Except ( ExceptT(..) ) -import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.Reader ( MonadReader(ask, local) ) -import Control.Monad.RWS.Class ( MonadRWS ) -import Control.Monad.State.Lazy ( MonadState(get, put) ) -import Control.Monad.Trans.Maybe ( MaybeT(MaybeT) ) -import Control.Monad.Writer.Class ( MonadWriter(..) ) -import Data.Bifoldable ( Bifoldable(bifoldMap) ) -import Data.Bifunctor ( Bifunctor(bimap) ) -import Data.Bitraversable ( Bitraversable(..) ) -import Data.Bool ( bool ) -import Data.Either ( Either(..), either ) -import Data.Eq ( Eq((==)) ) -import Data.Foldable ( Foldable(foldMap) ) -import Data.Function ( ($), const ) -import Data.Functor ( Functor(fmap), (<$>) ) -import Data.Functor.Alt ( Alt(()) ) -import Data.Functor.Apply ( Apply((<.>)) ) -import Data.Functor.Bind ( Bind((>>-)) ) -import Data.Functor.Classes - ( compare1, - eq1, - showsPrec1, - showsUnaryWith, - Eq1(..), - Ord1(..), - Show1(..) ) -import Data.Functor.Extend ( Extend(..) ) -import Data.Functor.Identity ( Identity(Identity, runIdentity) ) -import Data.Int ( Int ) -import Data.Maybe ( Maybe(Nothing, Just), fromMaybe ) -import Data.Monoid ( Monoid(mempty) ) -import Data.Ord ( Ord(compare) ) -import Data.Semigroup ( Semigroup((<>)) ) -import Data.Traversable ( Traversable(traverse) ) -import Data.Tuple ( uncurry ) -import GHC.Show ( Show(showsPrec) ) -import System.Exit ( ExitCode(..) ) -import System.IO ( IO ) - --- $setup --- >>> import Prelude --- >>> import Control.Lens - --- | An exit code status where failing with a value `0` cannot be represented. --- --- Transformer for either a (non-zero exit code value (`Int`) with error :: `e`) or a (value :: `a`). -newtype ExitcodeT f e a = - ExitcodeT (f (Either (e, Int) a)) - -type Exitcode e a = - ExitcodeT Identity e a - -type ExitcodeT0 f = - ExitcodeT f () () - -type Exitcode0 = - Exitcode () () - --- | Construct a succeeding exit code with the given value. --- --- >>> exitsuccess "abc" :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "abc")) -exitsuccess :: - Applicative f => - a - -> ExitcodeT f e a -exitsuccess = - ExitcodeT . pure . Right - --- | Construct a succeeding exit code with unit. --- --- >>> exitsuccess0 :: ExitcodeT0 Identity --- ExitcodeT (Identity (Right ())) -exitsuccess0 :: - Applicative f => - ExitcodeT f e () -exitsuccess0 = - exitsuccess () - --- | Construct a failing exit code with the given status. --- --- If the given status is `0` then the exit code will succeed with unit. --- --- >>> exitfailure 'x' 99 :: ExitcodeT Identity Char () --- ExitcodeT (Identity (Left ('x',99))) -exitfailure :: - Applicative f => - e - -> Int - -> ExitcodeT f e () -exitfailure e n = - exitcodeValue e n () - --- | Construct a failing exit code with the given status. --- --- If the given status is `0` then the exit code will succeed with unit. -exitfailure0 :: - Applicative f => - Int - -> ExitcodeT0 f -exitfailure0 = - exitfailure () - --- | Construct a failing exit code with the given status. --- If zero (0) is passed meaning success, use negative one (-1). --- --- >>> exitfailureNeg1 "abc" 0 :: Exitcode String () --- ExitcodeT (Identity (Left ("abc",-1))) --- --- >>> exitfailureNeg1 "abc" 12 :: Exitcode String () --- ExitcodeT (Identity (Left ("abc",12))) -exitfailureNeg1 :: - Applicative f => - e - -> Int - -> ExitcodeT f e a -exitfailureNeg1 e n = - liftExitFailureNeg1 (pure (e, n)) - --- | Construct an exit code with the given status. --- Associate a value of type `e` with a failing exit code and a value of the type `a` with a success exit code. --- --- If the given status is `0` then the exit code will succeed with unit. --- --- >>> exitcodeValue 'x' 99 "abc" :: ExitcodeT Identity Char String --- ExitcodeT (Identity (Left ('x',99))) --- >>> exitcodeValue 'x' 0 "abc" :: ExitcodeT Identity Char String --- ExitcodeT (Identity (Right "abc")) -exitcodeValue :: - Applicative f => - e - -> Int - -> a - -> ExitcodeT f e a -exitcodeValue e n = - liftExitcodeFailure (pure (e, n)) - --- | Construct an exit code with the given status. --- --- If the given status is `0` then the exit code will succeed with unit. --- --- >>> exitcodeValue0 99 :: ExitcodeT0 Identity --- ExitcodeT (Identity (Left ((),99))) --- >>> exitcodeValue0 0 :: ExitcodeT0 Identity --- ExitcodeT (Identity (Right ())) -exitcodeValue0 :: - Applicative f => - Int - -> ExitcodeT0 f -exitcodeValue0 n = - exitcodeValue () n () - --- | From base exitcode. --- --- >>> fromExitCode (Identity ExitSuccess) --- ExitcodeT (Identity (Right ())) --- >>> fromExitCode (Identity (ExitFailure 99)) --- ExitcodeT (Identity (Left ((),99))) -fromExitCode :: - Functor f => - f ExitCode - -> ExitcodeT0 f -fromExitCode x = - let ExitcodeT (MaybeT r) = view exitCode x - in ExitcodeT (fromMaybe (Right ()) <$> r) - --- | From base exitcode. --- --- >>> fromExitCode' ExitSuccess --- ExitcodeT (Identity (Right ())) --- >>> fromExitCode' (ExitFailure 99) --- ExitcodeT (Identity (Left ((),99))) --- >>> fromExitCode' (ExitFailure 0) --- ExitcodeT (Identity (Right ())) -fromExitCode' :: - ExitCode - -> Exitcode0 -fromExitCode' = - fromExitCode . Identity - --- | Isomorphism from base exitcode to underlying `Maybe (Either Int ())` where `Int` is non-zero. --- --- >>> view exitCode (Identity (ExitFailure 99)) --- ExitcodeT (MaybeT (Identity (Just (Left ((),99))))) --- >>> view exitCode (Identity ExitSuccess) --- ExitcodeT (MaybeT (Identity (Just (Right ())))) --- >>> review exitCode (exitfailure0 99) :: Identity ExitCode --- Identity (ExitFailure 99) --- >>> review exitCode exitsuccess0 :: Identity ExitCode --- Identity ExitSuccess -exitCode :: - (Functor f, Functor g) => - Iso - (f ExitCode) - (g ExitCode) - (ExitcodeT0 (MaybeT f)) - (ExitcodeT0 (MaybeT g)) -exitCode = - iso - (\x -> ExitcodeT (MaybeT ((\case - ExitSuccess -> - Just (Right ()) - ExitFailure 0 -> - Nothing - ExitFailure n -> - Just (Left ((), n))) <$> x))) - (\(ExitcodeT (MaybeT x)) -> (\case - Just (Right ()) -> - ExitSuccess - Nothing -> - ExitFailure 0 - Just (Left ((), n)) -> - ExitFailure n) <$> x) - --- | Extract either the non-zero value or the success value. --- --- >>> runExitcodeT exitsuccess0 :: Identity (Either ((), Int) ()) --- Identity (Right ()) --- >>> runExitcodeT (exitfailure0 99) :: Identity (Either ((), Int) ()) --- Identity (Left ((),99)) -runExitcodeT :: - ExitcodeT f e a - -> f (Either (e, Int) a) -runExitcodeT (ExitcodeT x) = - x - --- | Extract either the non-zero value or `Nothing`. --- --- >>> maybeExitcodeT exitsuccess0 :: Identity (Maybe Int) --- Identity Nothing --- >>> maybeExitcodeT (exitfailure0 99) :: Identity (Maybe Int) --- Identity (Just 99) -maybeExitcodeT :: - Functor f => - ExitcodeT f e a - -> f (Maybe Int) -maybeExitcodeT x = - preview (_Left . _2) <$> runExitcodeT x - --- | Extract either the non-zero value or the success value. --- --- >>> runExitcode exitsuccess0 :: Either ((), Int) () --- Right () --- >>> runExitcode (exitfailure0 99) :: Either ((), Int) () --- Left ((),99) -runExitcode :: - Exitcode e a - -> Either (e, Int) a -runExitcode = - runIdentity . runExitcodeT - --- | Extract either the non-zero value or `Nothing`. --- --- >>> maybeExitcode exitsuccess0 :: Maybe Int --- Nothing --- >>> maybeExitcode (exitfailure0 99) :: Maybe Int --- Just 99 -maybeExitcode :: - Exitcode0 - -> Maybe Int -maybeExitcode = - runIdentity . maybeExitcodeT - --- | Isomorphism to integer. --- --- >>> view _ExitcodeInt exitsuccess0 :: [Int] --- [0] --- >>> view _ExitcodeInt (exitfailure0 99) :: [Int] --- [99] --- >>> review _ExitcodeInt [0] --- ExitcodeT [Right ()] --- >>> review _ExitcodeInt [99] --- ExitcodeT [Left ((),99)] -_ExitcodeInt :: - (Functor f, Functor f') => - Iso - (ExitcodeT0 f) - (ExitcodeT0 f') - (f Int) - (f' Int) -_ExitcodeInt = - iso - (\(ExitcodeT x) -> fmap (either (view _2) (\() -> 0)) x) - (\x -> liftExitcodeFailure (((),) <$> x) ()) - --- | Setter to integer. --- --- >>> preview _ExitcodeInt' (exitsuccess0 :: ExitcodeT0 []) --- Just 0 --- >>> preview _ExitcodeInt' (exitfailure0 99 :: ExitcodeT0 []) --- Just 99 --- >>> preview _ExitcodeInt' (exitfailure0 0 :: ExitcodeT0 []) --- Just 0 --- >>> over _ExitcodeInt' (subtract 1) exitsuccess0 :: ExitcodeT0 Identity --- ExitcodeT (Identity (Left ((),-1))) --- >>> over _ExitcodeInt' (subtract 1) (exitfailure0 99) :: ExitcodeT0 Identity --- ExitcodeT (Identity (Left ((),98))) --- >>> over _ExitcodeInt' (subtract 1) (exitfailure0 1) :: ExitcodeT0 Identity --- ExitcodeT (Identity (Right ())) -_ExitcodeInt' :: - Traversable f => - Traversal' - (ExitcodeT0 f) - Int -_ExitcodeInt' = - _ExitcodeInt . traverse - --- | A traversal to exit failure. --- --- >>> preview _ExitFailure (exitfailure0 99 :: ExitcodeT0 Identity) --- Just ((),99) --- >>> preview _ExitFailure (exitsuccess0 :: ExitcodeT0 Identity) --- Nothing --- >>> over _ExitFailure (\(e, n) -> (e + 1, n + 1)) (exitsuccess0 :: ExitcodeT Identity Int ()) --- ExitcodeT (Identity (Right ())) --- >>> over _ExitFailure (\(e, n) -> (reverse e, n + 1)) (exitfailure "abc" 1 :: ExitcodeT Identity String ()) --- ExitcodeT (Identity (Left ("cba",2))) --- >>> over _ExitFailure (\(e, n) -> (reverse e, n - 1)) (exitfailure "abc" 1 :: ExitcodeT Identity String ()) --- ExitcodeT (Identity (Right ())) -_ExitFailure :: - Traversable f => - Traversal - (ExitcodeT f e ()) - (ExitcodeT f e' ()) - (e, Int) - (e', Int) -_ExitFailure f (ExitcodeT x) = - ExitcodeT <$> traverse (either (\z -> runExitcodeT (liftExitcodeFailure (f z) ())) (pure . pure)) x - --- | A traversal over the associated failing value. --- --- >>> over _ExitFailureError reverse exitsuccess0 :: ExitcodeT Identity [Int] () --- ExitcodeT (Identity (Right ())) --- >>> over _ExitFailureError reverse (exitfailure "abc" 99) :: ExitcodeT Identity String () --- ExitcodeT (Identity (Left ("cba",99))) --- >>> over _ExitFailureError reverse (exitfailure "abc" 0) :: ExitcodeT Identity String () --- ExitcodeT (Identity (Right ())) --- >>> preview _ExitFailureError (exitfailure0 99 :: ExitcodeT0 Identity) --- Just () --- >>> preview _ExitFailureError (exitsuccess0 :: ExitcodeT0 Identity) --- Nothing -_ExitFailureError :: - Traversable f => - Traversal - (ExitcodeT f e a) - (ExitcodeT f e' a) - e - e' -_ExitFailureError f (ExitcodeT x) = - ExitcodeT <$> traverse (either (\(e, n) -> (\e' -> Left (e', n)) <$> f e) (pure . Right)) x - --- | A prism to exit success. --- --- >>> over _ExitSuccess (\x -> x) (exitfailure0 99) --- ExitcodeT (Identity (Left ((),99))) --- >>> over _ExitSuccess (\x -> x) (exitfailure0 0) --- ExitcodeT (Identity (Right ())) --- >>> over _ExitSuccess (\x -> x) (exitfailure0 0) --- ExitcodeT (Identity (Right ())) --- >>> preview _ExitSuccess (exitfailure0 99) --- Nothing --- >>> preview _ExitSuccess exitsuccess0 --- Just () --- >>> review _ExitSuccess "abc" :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "abc")) -_ExitSuccess :: - Prism - (Exitcode e a) - (Exitcode e a') - a - a' -_ExitSuccess = - prism - exitsuccess - (\(ExitcodeT (Identity x)) -> - over _Left (ExitcodeT . Identity . Left) x - ) - -instance Functor f => Functor (ExitcodeT f e) where - fmap f (ExitcodeT x) = - ExitcodeT (fmap (fmap f) x) - -instance Monad f => Apply (ExitcodeT f e) where - ExitcodeT f <.> ExitcodeT a = - ExitcodeT (f >>= either (pure . Left) (\f' -> fmap (fmap f') a)) - -instance Monad f => Applicative (ExitcodeT f e) where - pure = - ExitcodeT . pure . pure - ExitcodeT f <*> ExitcodeT a = - ExitcodeT (f >>= either (pure . Left) (\f' -> fmap (fmap f') a)) - --- | --- --- >>> exitsuccess "abc" >>- \s -> exitsuccess (reverse s) :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "cba")) --- >>> exitsuccess "abc" >>- \_ -> exitfailure0 99 :: ExitcodeT0 Identity --- ExitcodeT (Identity (Left ((),99))) --- >>> exitfailure 'x' 99 >>- \_ -> exitsuccess "abc" :: ExitcodeT Identity Char String --- ExitcodeT (Identity (Left ('x',99))) --- >>> exitfailure 'x' 99 >>- \_ -> exitfailure 'y' 88 :: ExitcodeT Identity Char () --- ExitcodeT (Identity (Left ('x',99))) --- >>> let loop = loop in exitfailure0 99 >>- loop :: ExitcodeT0 Identity --- ExitcodeT (Identity (Left ((),99))) -instance Monad f => Bind (ExitcodeT f e) where - (>>-) = - (>>=) - -instance Monad f => Monad (ExitcodeT f e) where - return = - pure - ExitcodeT x >>= f = - ExitcodeT - (x >>= either (pure . Left) (runExitcodeT . f)) - --- | --- --- >>> exitsuccess "abc" exitsuccess "def" :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "abc")) --- >>> exitsuccess "abc" exitcodeValue () 99 "def" :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "abc")) --- >>> exitcodeValue 'x' 99 "abc" exitsuccess "def" :: ExitcodeT Identity Char String --- ExitcodeT (Identity (Right "def")) --- >>> exitcodeValue 'x' 99 "abc" exitcodeValue 'y' 88 "def" :: ExitcodeT Identity Char String --- ExitcodeT (Identity (Left ('y',88))) -instance Monad f => Alt (ExitcodeT f e) where - ExitcodeT a ExitcodeT b = - ExitcodeT (a >>= either (const b) (pure a)) - --- | --- --- >>> exitsuccess "abc" <> exitsuccess "def" :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "abcdef")) --- >>> exitsuccess "abc" <> exitcodeValue () 99 "def" :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "abc")) --- >>> exitcodeValue 'x' 99 "abc" <> exitsuccess "def" :: ExitcodeT Identity Char String --- ExitcodeT (Identity (Right "def")) --- >>> exitcodeValue 'x' 99 "abc" <> exitcodeValue 'y' 88 "def" :: ExitcodeT Identity Char String --- ExitcodeT (Identity (Left ('y',88))) -instance (Semigroup a, Applicative f) => Semigroup (ExitcodeT f e a) where - ExitcodeT a <> ExitcodeT b = - let jn (Left _) x = x - jn x (Left _) = x - jn (Right a1) (Right a2) = Right (a1 <> a2) - in ExitcodeT (liftA2 jn a b) - --- | --- --- >>> mempty :: ExitcodeT Identity () String --- ExitcodeT (Identity (Right "")) -instance (Monoid a, Applicative f) => Monoid (ExitcodeT f e a) where - mempty = - ExitcodeT (pure (Right mempty)) - --- | --- --- >>> duplicated (exitfailure0 0) :: ExitcodeT Identity () (ExitcodeT0 Identity) --- ExitcodeT (Identity (Right (ExitcodeT (Identity (Right ()))))) --- >>> duplicated (exitfailure0 99) :: ExitcodeT Identity () (ExitcodeT0 Identity) --- ExitcodeT (Identity (Right (ExitcodeT (Identity (Left ((),99)))))) --- >>> duplicated (exitsuccess "abc") :: ExitcodeT Identity () (ExitcodeT Identity () String) --- ExitcodeT (Identity (Right (ExitcodeT (Identity (Right "abc"))))) -instance Extend f => Extend (ExitcodeT f e) where - duplicated (ExitcodeT x) = - ExitcodeT (extended (Right . ExitcodeT) x) - -instance (Eq1 f, Eq e, Eq a) => Eq (ExitcodeT f e a) where - ExitcodeT a == ExitcodeT b = - a `eq1` b - -instance (Eq1 f, Eq e) => Eq1 (ExitcodeT f e) where - liftEq f (ExitcodeT a) (ExitcodeT b) = - liftEq (liftEq f) a b - -instance (Ord1 f, Ord e, Ord a) => Ord (ExitcodeT f e a) where - ExitcodeT a `compare` ExitcodeT b = - a `compare1` b - -instance (Ord1 f, Ord e) => Ord1 (ExitcodeT f e) where - liftCompare f (ExitcodeT a) (ExitcodeT b) = - liftCompare (liftCompare f) a b - -instance (Show1 f, Show e, Show a) => Show (ExitcodeT f e a) where - showsPrec d (ExitcodeT m) = - showsUnaryWith showsPrec1 "ExitcodeT" d m - -instance (Show1 f, Show e) => Show1 (ExitcodeT f e) where - liftShowsPrec sp sl d (ExitcodeT fa) = - let showsPrecF = liftA2 liftShowsPrec (uncurry liftShowsPrec) (uncurry liftShowList) (sp, sl) - in showsUnaryWith showsPrecF "ExitcodeT" d fa - -instance Foldable f => Foldable (ExitcodeT f e) where - foldMap f (ExitcodeT x) = - foldMap (foldMap f) x - --- | --- --- >>> traverse (\x -> x) [exitfailure 'x' 99] :: ExitcodeT Identity Char [()] --- ExitcodeT (Identity (Left ('x',99))) --- >>> traverse (\x -> x) [exitfailure 'x' 99, exitsuccess0] :: ExitcodeT Identity Char [()] --- ExitcodeT (Identity (Left ('x',99))) --- >>> traverse (\x -> x) [exitfailure 'x' 99, exitsuccess0, exitfailure 'y' 88] :: ExitcodeT Identity Char [()] --- ExitcodeT (Identity (Left ('x',99))) --- >>> traverse (\x -> x) [exitsuccess0, exitfailure 'x' 88] :: ExitcodeT Identity Char [()] --- ExitcodeT (Identity (Left ('x',88))) --- >>> traverse (\x -> x) [exitsuccess0] :: ExitcodeT Identity () [()] --- ExitcodeT (Identity (Right [()])) -instance Traversable f => Traversable (ExitcodeT f e) where - traverse f (ExitcodeT x) = - ExitcodeT <$> traverse (traverse f) x - -instance MonadIO f => MonadIO (ExitcodeT f e) where - liftIO io = - ExitcodeT (Right <$> liftIO io) - -liftExitcode :: - Functor f => - f a - -> ExitcodeT f e a -liftExitcode x = - ExitcodeT (Right <$> x) - -liftExitcodeFailure :: - Functor f => - f (e, Int) - -> a - -> ExitcodeT f e a -liftExitcodeFailure x a = - ExitcodeT ((\(e, n) -> bool (Left (e, n)) (Right a) (n == 0)) <$> x) - -liftExitcodeFailure0 :: - Functor f => - f Int - -> ExitcodeT0 f -liftExitcodeFailure0 x = - liftExitcodeFailure (((),) <$> x) () - --- | --- --- If the given exitcode is success (0), return a failure and make the exitcode negative one (-1). -liftExitFailureNeg1 :: - Functor f => - f (e, Int) - -> ExitcodeT f e a -liftExitFailureNeg1 x = - ExitcodeT ((\(e, n) -> Left (e, bool n (-1) (n == 0))) <$> x) - -hoistExitcode :: - (forall x. f x -> g x) - -> ExitcodeT f e a - -> ExitcodeT g e a -hoistExitcode nat (ExitcodeT x) = - ExitcodeT (nat x) - -embedExitcode :: - Functor g => - (forall x. f x -> ExitcodeT g e x) - -> ExitcodeT f e a - -> ExitcodeT g e a -embedExitcode nat (ExitcodeT x) = - ExitcodeT (join <$> runExitcodeT (nat x)) - -instance MonadReader r f => MonadReader r (ExitcodeT f e) where - ask = - liftExitcode ask - local f (ExitcodeT m) = - ExitcodeT (local f m) - --- | --- --- >>> writer ('x', "abc") :: ExitcodeT ((,) String) () Char --- ExitcodeT ("abc",Right 'x') --- >>> listen (exitfailure 'x' 99 :: ExitcodeT ((,) String) Char ()) --- ExitcodeT ("",Left ('x',99)) --- >>> listen (exitsuccess 99 :: ExitcodeT ((,) String) () Int) --- ExitcodeT ("",Right (99,"")) --- >>> tell "abc" :: ExitcodeT0 ((,) String) --- ExitcodeT ("abc",Right ()) --- >>> pass (exitsuccess ('x', reverse)) :: ExitcodeT ((,) String) () Char --- ExitcodeT ("",Right 'x') --- >>> pass (('x', reverse) <$ (exitfailure 'x' 99 :: ExitcodeT ((,) String) Char ())) --- ExitcodeT ("",Left ('x',99)) -instance MonadWriter w f => MonadWriter w (ExitcodeT f e) where - writer t = - ExitcodeT . fmap pure $ writer t - listen (ExitcodeT m) = - ExitcodeT ((\(e, w) -> (,w) <$> e) <$> listen m) - tell = - ExitcodeT . fmap Right . tell - pass e = - do ((a, f), w) <- listen e - tell (f w) - pure a - -instance MonadState s f => MonadState s (ExitcodeT f e) where - get = - ExitcodeT (fmap Right get) - put = - ExitcodeT . fmap Right . put - --- | --- --- >>> throwError 99 :: ExitcodeT (Either Int) () String --- ExitcodeT (Left 99) --- >>> catchError exitsuccess0 (exitfailure 'x') :: ExitcodeT (Either Int) Char () --- ExitcodeT (Right (Right ())) --- >>> catchError (exitfailure 'x' 99) (\_ -> exitsuccess0) :: ExitcodeT (Either Int) Char () --- ExitcodeT (Right (Left ('x',99))) --- >>> catchError (exitfailure 'x' 99) (exitfailure 'y') :: ExitcodeT (Either Int) Char () --- ExitcodeT (Right (Left ('x',99))) --- >>> catchError exitsuccess0 (\_ -> exitsuccess0) :: ExitcodeT0 (Either Int) --- ExitcodeT (Right (Right ())) -instance MonadError e f => MonadError e (ExitcodeT f e') where - throwError = - ExitcodeT . fmap Right . throwError - catchError (ExitcodeT f) h = - ExitcodeT (catchError f (runExitcodeT . h)) - -instance MonadRWS r w s f => MonadRWS r w s (ExitcodeT f e) - --- Given the embedded `Either` we can only handle computations that use `Either`. --- This code taken from the ExceptT instance: --- https://hackage.haskell.org/package/transformers-0.5.4.0/docs/src/Control.Monad.Trans.Except.html#line-237 -instance MonadCont f => MonadCont (ExitcodeT f e) where - callCC = - let liftCallCC callCC' f = - ExitcodeT . callCC' $ - \c -> runExitcodeT (f (ExitcodeT . c . Right)) - in liftCallCC callCC - -instance Functor f => Bifunctor (ExitcodeT f) where - bimap f g (ExitcodeT x) = - ExitcodeT (fmap (bimap (over _1 f) g) x) - -instance Foldable f => Bifoldable (ExitcodeT f) where - bifoldMap f g (ExitcodeT x) = - foldMap (bifoldMap (f . view _1) g) x - -instance Traversable f => Bitraversable (ExitcodeT f) where - bitraverse f g (ExitcodeT x) = - ExitcodeT <$> traverse (bitraverse (\(a, n) -> (, n) <$> f a) g) x - -type ExitcodeT1 f a = - ExitcodeT f a a - -type Exitcode1 a = - ExitcodeT1 Identity a - --- | Construct an exitcode with an associated value. --- --- >>> exitcode1 99 "abc" :: ExitcodeT1 Identity String --- ExitcodeT (Identity (Left ("abc",99))) --- >>> exitcode1 0 "abc" :: ExitcodeT1 Identity String --- ExitcodeT (Identity (Right "abc")) -exitcode1 :: - Applicative f => - Int - -> a - -> ExitcodeT1 f a -exitcode1 n a = - exitcodeValue a n a - --- | Extract either the non-zero value or the success value. --- --- >>> runExitcodeT1 exitsuccess0 --- Right () --- >>> runExitcodeT1 (exitfailure0 99) :: Identity (Either ((), Int) ()) --- Identity (Left ((),99)) --- >>> runExitcodeT1 (exitcode1 0 "abc") :: Identity (Either (String, Int) String) --- Identity (Right "abc") --- >>> runExitcodeT1 (exitcode1 99 "abc") :: Identity (Either (String, Int) String) --- Identity (Left ("abc",99)) -runExitcodeT1 :: - ExitcodeT1 f a - -> f (Either (a, Int) a) -runExitcodeT1 (ExitcodeT x) = - x - --- | Extract either the non-zero value or the success value. --- --- >>> runExitcode1 exitsuccess0 --- Right () --- >>> runExitcode1 (exitfailure0 99) --- Left ((),99) --- >>> runExitcode1 (exitcode1 0 "abc") --- Right "abc" --- >>> runExitcode1 (exitcode1 99 "abc") --- Left ("abc",99) -runExitcode1 :: - Exitcode1 a - -> Either (a, Int) a -runExitcode1 = - runIdentity . runExitcodeT1 - --- | Try the IO action producing the exitcode, possibly throwing an exception. -tryExitcode :: - Exception e' => - ExitcodeT IO e a - -> ExitcodeT (ExceptT e' IO) e a -tryExitcode (ExitcodeT x) = - ExitcodeT (ExceptT (try x)) +{-# OPTIONS_GHC -Wall #-} --- | Try the IO action producing the exitcode, possibly throwing an exception. -liftTryExitcode :: - Exception e' => - IO a - -> ExitcodeT (ExceptT e' IO) e a -liftTryExitcode x = - ExitcodeT (ExceptT (fmap (fmap Right) (try x))) +module Control.Exitcode + ( module Control.Exitcode.Exitcode, + module Control.Exitcode.Optics, + ) +where --- | A lens to the value associated with an exitcode. --- --- >>> view _Exitcode1 (exitcode1 0 "abc") --- "abc" --- >>> view _Exitcode1 (exitcode1 99 "abc") --- "abc" --- >>> view _Exitcode1 (exitcodeValue "abc" 0 "def") --- "def" --- >>> view _Exitcode1 (exitcodeValue "abc" 99 "def") --- "abc" --- >>> over _Exitcode1 reverse (exitcode1 0 "abc") --- ExitcodeT (Identity (Right "cba")) --- >>> over _Exitcode1 reverse (exitcode1 99 "abc") --- ExitcodeT (Identity (Left ("cba",99))) --- >>> over _Exitcode1 reverse (exitcodeValue "abc" 0 "def") --- ExitcodeT (Identity (Right "fed")) --- >>> over _Exitcode1 reverse (exitcodeValue "abc" 99 "def") --- ExitcodeT (Identity (Left ("cba",99))) -_Exitcode1 :: - Lens - (Exitcode1 a) - (Exitcode1 a') - a - a' -_Exitcode1 f = - either - (\(a, n) -> fmap (exitcode1 n) (f a)) - (fmap (exitcode1 0) . f) - . runExitcode1 +import Control.Exitcode.Exitcode +import Control.Exitcode.Optics diff --git a/src/Control/Exitcode/Exitcode.hs b/src/Control/Exitcode/Exitcode.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exitcode/Exitcode.hs @@ -0,0 +1,1156 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +-- Required for instances like MonadReader r (Exitcode e f) where the +-- constraint MonadReader r f does not structurally decrease. +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +module Control.Exitcode.Exitcode + ( -- * Types + Exitcode (..), + Exitcode', + ExitcodeBifunctor (..), + ExitcodeBifunctor', + + -- * Construction + mkExitcode, + mkExitcode', + mkExitSuccess, + mkExitSuccess', + mkExitFailure, + mkExitFailure', + mkExitFailure1, + mkExitFailure1', + mkExitFailure_1, + mkExitFailure_1', + fromExitCode, + fromExitCode', + toExitCode, + toExitCode', + hoistExitcode, + embedExitcode, + bimapExitcode, + + -- * Extraction + runExitcode, + maybeExitcode, + maybeExitcode', + + -- * Exceptions + tryExitcode, + liftTryExitcode, + + -- * Optics + exitCode, + _Exitcode1, + _Exitcode1', + _ExitFailure, + _ExitFailure', + _ExitFailureCode, + _ExitFailureCode', + _ExitFailureValue, + _ExitFailureValue', + _ExitSuccess, + _ExitSuccess', + ) +where + +import Control.Applicative (Applicative (pure, (<*>))) +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf)) +import Control.Exception (Exception, try) +import Control.Lens (FoldableWithIndex (ifoldMap), FunctorWithIndex (imap), Iso, Lens, Prism, Prism', Traversal, Traversal', TraversableWithIndex (itraverse), iso, preview, prism, prism', review, _Wrapped) +import Control.Monad (Monad ((>>=)), join) +import Control.Monad.Cont.Class (MonadCont (..)) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.Fix (MonadFix (mfix)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.RWS.Class (MonadRWS) +import Control.Monad.Reader (MonadReader (ask, local), asks) +import Control.Monad.State.Lazy (MonadState (get, put)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Control.Monad.Writer.Class (MonadWriter (..)) +import Data.Bifoldable (Bifoldable (bifoldMap)) +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Bitraversable (Bitraversable (bitraverse)) +import Data.Either (Either (..), either) +import Data.Eq (Eq ((==))) +import Data.Foldable (Foldable (foldMap, toList)) +import Data.Function (const, id, ($), (.)) +import Data.Functor (Functor (fmap), (<$>)) +import Data.Functor.Alt (Alt (())) +import Data.Functor.Apply (Apply ((<.>))) +import Data.Functor.Bind (Bind ((>>-))) +import Data.Functor.Bind.Trans (BindTrans (..)) +import Data.Functor.Classes + ( Eq1 (liftEq), + Ord1 (liftCompare), + Show1 (liftShowList, liftShowsPrec), + ) +import Data.Functor.Extend (Extend (duplicated, extended)) +import Data.Functor.Identity (Identity (Identity, runIdentity)) +import Data.Int (Int) +import Data.Maybe (Maybe (Just, Nothing)) +import Data.Monoid (Monoid (mempty)) +import Data.Ord (Ord (compare), (>)) +import Data.Semigroup (Semigroup ((<>))) +import Data.Traversable (Traversable (traverse), mapAccumL) +import Data.Tuple (fst, snd) +import GHC.Generics (Generic) +import GHC.Show (Show (showsPrec), showParen, showString) +import Natural (NotZero, _NotZero, notZeroOr) +import Prelude (seq) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) +import System.IO (IO) + +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens +-- >>> import Natural +-- >>> let nz1 = positiveNotZero one' +-- >>> let nz2 = positiveNotZero (successor1' one') + +-- | An exit code status where failing with a value @0@ cannot be represented. +-- +-- Wraps @f (Either (e, NotZero) a)@ where the @NotZero@ in the @Left@ branch +-- is a proven non-zero integer. +newtype Exitcode e f a + = Exitcode (f (Either (e, NotZero) a)) + deriving stock (Generic) + +-- | @Exitcode@ specialised to @Identity@. +type Exitcode' e a = + Exitcode e Identity a + +-- * Extraction + +-- | Extract the underlying @f (Either (e, NotZero) a)@. +-- +-- >>> runExitcode (mkExitSuccess' "abc") +-- Identity (Right "abc") +-- >>> runExitcode (mkExitFailure1' 'x') +-- Identity (Left ('x',NotZero True (Positive 1))) +{-# INLINE runExitcode #-} +runExitcode :: + Exitcode e f a -> + f (Either (e, NotZero) a) +runExitcode (Exitcode x) = + x + +-- | Extract the exit code as @Maybe NotZero@: @Nothing@ for success, @Just n@ for failure. +-- +-- >>> maybeExitcode (mkExitSuccess (Identity ())) :: Identity (Maybe NotZero) +-- Identity Nothing +-- >>> maybeExitcode (mkExitFailure1 (Identity ())) :: Identity (Maybe NotZero) +-- Identity (Just (NotZero True (Positive 1))) +{-# INLINE maybeExitcode #-} +maybeExitcode :: + (Functor f) => + Exitcode e f a -> + f (Maybe NotZero) +maybeExitcode (Exitcode x) = + fmap (either (Just . snd) (const Nothing)) x + +-- | @maybeExitcode@ specialised to @Identity@. +-- +-- >>> maybeExitcode' (mkExitSuccess' ()) +-- Nothing +-- >>> maybeExitcode' (mkExitFailure1' ()) +-- Just (NotZero True (Positive 1)) +{-# INLINE maybeExitcode' #-} +maybeExitcode' :: + Exitcode' e a -> + Maybe NotZero +maybeExitcode' (Exitcode x) = + either (Just . snd) (const Nothing) (runIdentity x) + +-- * Optics + +-- | Iso between @f ExitCode@ and @Exitcode () (MaybeT f) ()@. +-- +-- @ExitFailure 0@ maps to @MaybeT Nothing@ (neither success nor failure). +-- @ExitSuccess@ maps to a success exitcode. +-- @ExitFailure n@ (where @n /= 0@) maps to a failure exitcode. +-- +-- >>> import Control.Monad.Trans.Maybe +-- >>> view exitCode (Identity ExitSuccess) +-- Exitcode (MaybeT (Identity (Just (Right ())))) +-- >>> view exitCode (Identity (ExitFailure 99)) +-- Exitcode (MaybeT (Identity (Just (Left ((),NotZero True (Positive 99)))))) +-- >>> view exitCode (Identity (ExitFailure 0)) +-- Exitcode (MaybeT (Identity Nothing)) +-- >>> review exitCode (mkExitSuccess (MaybeT (Identity (Just ())))) +-- Identity ExitSuccess +-- >>> review exitCode (mkExitFailure1 (MaybeT (Identity (Just ())))) +-- Identity (ExitFailure 1) +{-# INLINE exitCode #-} +exitCode :: + (Functor f, Functor g) => + Iso + (f ExitCode) + (g ExitCode) + (Exitcode () (MaybeT f) ()) + (Exitcode () (MaybeT g) ()) +exitCode = + iso + ( Exitcode + . MaybeT + . fmap + ( \case + ExitSuccess -> Just (Right ()) + ExitFailure n -> fmap (Left . ((),)) (preview _NotZero n) + ) + ) + ( \(Exitcode (MaybeT x)) -> + fmap + ( \case + Just (Right ()) -> ExitSuccess + Nothing -> ExitFailure 0 + Just (Left ((), nz)) -> ExitFailure (review _NotZero nz) + ) + x + ) + +-- | Lens into the value of an @Exitcode' a a@, regardless of success or failure. +-- The exit code is preserved. +-- +-- >>> over _Exitcode1 reverse (mkExitcode' "abc" nz1 :: Exitcode' String String) +-- Exitcode (Identity (Left ("cba",NotZero True (Positive 1)))) +-- >>> over _Exitcode1 reverse (mkExitSuccess' "def") +-- Exitcode (Identity (Right "fed")) +{-# INLINE _Exitcode1 #-} +_Exitcode1 :: + Lens + (Exitcode' a a) + (Exitcode' a' a') + a + a' +_Exitcode1 g (Exitcode (Identity x)) = + fmap + (\a' -> Exitcode (Identity (either (\(_, n) -> Left (a', n)) (const (Right a')) x))) + (g (either fst id x)) + +-- | @_Exitcode1@ generalised to @Traversable f@. +-- +-- >>> over _Exitcode1' (fmap reverse) (mkExitcode (Identity "abc") (Identity nz1) :: Exitcode String Identity String) +-- Exitcode (Identity (Left ("cba",NotZero True (Positive 1)))) +-- >>> over _Exitcode1' (fmap reverse) (mkExitSuccess (Identity "def")) +-- Exitcode (Identity (Right "fed")) +{-# INLINE _Exitcode1' #-} +_Exitcode1' :: + (Traversable f) => + Traversal' (Exitcode a f a) (f a) +_Exitcode1' g (Exitcode x) = + fmap + ( \fa' -> + let (_, result) = + mapAccumL + ( \as' struct -> case as' of + (a' : rest) -> (rest, either (\(_, n) -> Left (a', n)) (const (Right a')) struct) + [] -> ([], struct) + ) + (toList fa') + x + in Exitcode result + ) + (g (fmap (either fst id) x)) + +-- | Prism into all-failure exitcodes. +-- +-- >>> preview _ExitFailure (mkExitFailure1' 'x' :: Exitcode' Char ()) +-- Just (Identity ('x',NotZero True (Positive 1))) +-- >>> preview _ExitFailure (mkExitSuccess' () :: Exitcode' Char ()) +-- Nothing +{-# INLINE _ExitFailure #-} +_ExitFailure :: (Traversable f) => Prism' (Exitcode e f a) (f (e, NotZero)) +_ExitFailure = + prism' + (Exitcode . fmap Left) + (\(Exitcode x) -> traverse (either Just (const Nothing)) x) + +-- | Type-changing prism into the failure case, specialised to @Identity@. +-- +-- >>> preview _ExitFailure' (mkExitFailure1' 'x' :: Exitcode' Char ()) +-- Just ('x',NotZero True (Positive 1)) +-- >>> preview _ExitFailure' (mkExitSuccess' () :: Exitcode' Char ()) +-- Nothing +-- >>> review _ExitFailure' ('y', nz2) :: Exitcode' Char () +-- Exitcode (Identity (Left ('y',NotZero True (Positive 2)))) +{-# INLINE _ExitFailure' #-} +_ExitFailure' :: Prism (Exitcode' e a) (Exitcode' e' a) (e, NotZero) (e', NotZero) +_ExitFailure' = + prism + (\(e', nz) -> Exitcode (Identity (Left (e', nz)))) + (\(Exitcode (Identity x)) -> case x of + Left (e, nz) -> Right (e, nz) + Right a -> Left (Exitcode (Identity (Right a)))) + +-- | Traversal into the @NotZero@ exit code values when all elements are failures. +-- +-- >>> over _ExitFailureCode' (const nz1) (mkExitFailure' nz2 'x') +-- Exitcode (Identity (Left ('x',NotZero True (Positive 1)))) +{-# INLINE _ExitFailureCode #-} +_ExitFailureCode :: (Traversable f) => Traversal' (Exitcode e f a) (f NotZero) +_ExitFailureCode g (Exitcode x) = + case traverse (either Just (const Nothing)) x of + Nothing -> pure (Exitcode x) + Just pairs -> + let rebuild newNZs = + let (_, result) = + mapAccumL + ( \ns (e, nz) -> case ns of + n : rest -> (rest, (e, n)) + [] -> ([], (e, nz)) + ) + (toList newNZs) + pairs + in Exitcode (fmap Left result) + in rebuild <$> g (fmap snd pairs) + +-- | @_ExitFailureCode@ specialised to @Identity@. +{-# INLINE _ExitFailureCode' #-} +_ExitFailureCode' :: Traversal' (Exitcode' e a) NotZero +_ExitFailureCode' = _ExitFailureCode . _Wrapped + +-- | Traversal into the error values when all elements are failures. +-- +-- >>> over _ExitFailureValue' (const 'y') (mkExitFailure1' 'x') +-- Exitcode (Identity (Left ('y',NotZero True (Positive 1)))) +-- >>> over _ExitFailureValue' (const 'y') (mkExitSuccess' () :: Exitcode' Char ()) +-- Exitcode (Identity (Right ())) +{-# INLINE _ExitFailureValue #-} +_ExitFailureValue :: (Traversable f) => Traversal' (Exitcode e f a) (f e) +_ExitFailureValue g (Exitcode x) = + case traverse (either Just (const Nothing)) x of + Nothing -> pure (Exitcode x) + Just pairs -> + let rebuild newEs = + let (_, result) = + mapAccumL + ( \es (e, nz) -> case es of + e' : rest -> (rest, (e', nz)) + [] -> ([], (e, nz)) + ) + (toList newEs) + pairs + in Exitcode (fmap Left result) + in rebuild <$> g (fmap fst pairs) + +-- | @_ExitFailureValue@ specialised to @Identity@. +{-# INLINE _ExitFailureValue' #-} +_ExitFailureValue' :: Traversal (Exitcode' e a) (Exitcode' e' a) e e' +_ExitFailureValue' g (Exitcode (Identity x)) = + case x of + Left (e, nz) -> fmap (\e' -> Exitcode (Identity (Left (e', nz)))) (g e) + Right a -> pure (Exitcode (Identity (Right a))) + +-- | Prism into all-success exitcodes. +-- +-- >>> preview _ExitSuccess (mkExitSuccess' "abc" :: Exitcode' () String) +-- Just (Identity "abc") +-- >>> preview _ExitSuccess (mkExitFailure1' () :: Exitcode' () String) +-- Nothing +{-# INLINE _ExitSuccess #-} +_ExitSuccess :: (Traversable f) => Prism' (Exitcode e f a) (f a) +_ExitSuccess = + prism' + (Exitcode . fmap Right) + (\(Exitcode x) -> traverse (either (const Nothing) Just) x) + +-- | @_ExitSuccess@ specialised to @Identity@. +-- +-- >>> preview _ExitSuccess' (mkExitSuccess' "abc" :: Exitcode' () String) +-- Just "abc" +-- >>> preview _ExitSuccess' (mkExitFailure1' () :: Exitcode' () String) +-- Nothing +{-# INLINE _ExitSuccess' #-} +_ExitSuccess' :: Prism (Exitcode' e a) (Exitcode' e a') a a' +_ExitSuccess' = + prism + (Exitcode . Identity . Right) + ( \(Exitcode (Identity x)) -> case x of + Right a -> Right a + Left (e, i) -> Left (Exitcode (Identity (Left (e, i)))) + ) + +-- | Construct a failure exitcode with an error value and a non-zero exit code. +-- +-- >>> mkExitcode (Identity 'x') (Identity nz1) :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero True (Positive 1)))) +{-# INLINE mkExitcode #-} +mkExitcode :: (Applicative f) => f e -> f NotZero -> Exitcode e f a +mkExitcode e nz = Exitcode ((\e' nz' -> Left (e', nz')) <$> e <*> nz) + +-- | @mkExitcode@ specialised to @Identity@. +-- +-- >>> mkExitcode' 'x' nz1 :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero True (Positive 1)))) +{-# INLINE mkExitcode' #-} +mkExitcode' :: e -> NotZero -> Exitcode' e a +mkExitcode' e nz = mkExitcode (Identity e) (Identity nz) + +-- | Construct a success exitcode. +-- +-- >>> mkExitSuccess (Identity "abc") :: Exitcode' () String +-- Exitcode (Identity (Right "abc")) +{-# INLINE mkExitSuccess #-} +mkExitSuccess :: (Functor f) => f a -> Exitcode e f a +mkExitSuccess = Exitcode . fmap Right + +-- | @mkExitSuccess@ specialised to @Identity@. +-- +-- >>> mkExitSuccess' "abc" :: Exitcode' () String +-- Exitcode (Identity (Right "abc")) +{-# INLINE mkExitSuccess' #-} +mkExitSuccess' :: a -> Exitcode' e a +mkExitSuccess' = mkExitSuccess . Identity + +-- | Construct a failure exitcode with a proven non-zero exit code. +-- +-- >>> mkExitFailure (Identity nz1) (Identity 'x') :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero True (Positive 1)))) +{-# INLINE mkExitFailure #-} +mkExitFailure :: (Applicative f) => f NotZero -> f e -> Exitcode e f a +mkExitFailure n e = Exitcode ((\n' e' -> Left (e', n')) <$> n <*> e) + +-- | @mkExitFailure@ specialised to @Identity@. +-- +-- >>> mkExitFailure' nz1 'x' :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero True (Positive 1)))) +{-# INLINE mkExitFailure' #-} +mkExitFailure' :: NotZero -> e -> Exitcode' e a +mkExitFailure' n e = mkExitFailure (Identity n) (Identity e) + +-- | Construct a failure exitcode with exit code @1@. +-- +-- >>> mkExitFailure1 (Identity 'x') :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero True (Positive 1)))) +{-# INLINE mkExitFailure1 #-} +mkExitFailure1 :: (Functor f) => f e -> Exitcode e f a +mkExitFailure1 = Exitcode . fmap (\e' -> Left (e', notZeroOr (1 :: Int))) + +-- | @mkExitFailure1@ specialised to @Identity@. +-- +-- >>> mkExitFailure1' 'x' :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero True (Positive 1)))) +{-# INLINE mkExitFailure1' #-} +mkExitFailure1' :: e -> Exitcode' e a +mkExitFailure1' = mkExitFailure1 . Identity + +-- | Construct a failure exitcode with exit code @-1@. +-- +-- >>> mkExitFailure_1 (Identity 'x') :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero False (Positive 1)))) +{-# INLINE mkExitFailure_1 #-} +mkExitFailure_1 :: (Functor f) => f e -> Exitcode e f a +mkExitFailure_1 = Exitcode . fmap (\e' -> Left (e', notZeroOr (-1 :: Int))) + +-- | @mkExitFailure_1@ specialised to @Identity@. +-- +-- >>> mkExitFailure_1' 'x' :: Exitcode' Char () +-- Exitcode (Identity (Left ('x',NotZero False (Positive 1)))) +{-# INLINE mkExitFailure_1' #-} +mkExitFailure_1' :: e -> Exitcode' e a +mkExitFailure_1' = mkExitFailure_1 . Identity + +-- | Convert from a base @ExitCode@. @ExitFailure 0@ is treated as success. +-- +-- >>> fromExitCode (Identity ExitSuccess) +-- Exitcode (Identity (Right ())) +-- >>> fromExitCode (Identity (ExitFailure 99)) +-- Exitcode (Identity (Left ((),NotZero True (Positive 99)))) +-- >>> fromExitCode (Identity (ExitFailure 0)) +-- Exitcode (Identity (Right ())) +{-# INLINE fromExitCode #-} +fromExitCode :: + (Functor f) => + f ExitCode -> + Exitcode () f () +fromExitCode = + Exitcode + . fmap + ( \case + ExitSuccess -> Right () + ExitFailure n -> case preview _NotZero n of + Just nz -> Left ((), nz) + Nothing -> Right () + ) + +-- | @fromExitCode@ specialised to @Identity@. +-- +-- >>> fromExitCode' ExitSuccess +-- Exitcode (Identity (Right ())) +-- >>> fromExitCode' (ExitFailure 99) +-- Exitcode (Identity (Left ((),NotZero True (Positive 99)))) +-- >>> fromExitCode' (ExitFailure 0) +-- Exitcode (Identity (Right ())) +{-# INLINE fromExitCode' #-} +fromExitCode' :: + ExitCode -> + Exitcode' () () +fromExitCode' = + fromExitCode . Identity + +-- | Convert an exitcode back to @f ExitCode@. +-- +-- >>> toExitCode (mkExitSuccess (Identity ())) +-- Identity ExitSuccess +-- >>> toExitCode (mkExitFailure1 (Identity ())) +-- Identity (ExitFailure 1) +{-# INLINE toExitCode #-} +toExitCode :: + (Functor f) => + Exitcode () f () -> + f ExitCode +toExitCode (Exitcode x) = + fmap (either (\((), nz) -> ExitFailure (review _NotZero nz)) (const ExitSuccess)) x + +-- | @toExitCode@ specialised to @Identity@. +-- +-- >>> toExitCode' (mkExitSuccess' ()) +-- ExitSuccess +-- >>> toExitCode' (mkExitFailure1' ()) +-- ExitFailure 1 +{-# INLINE toExitCode' #-} +toExitCode' :: + Exitcode' () () -> + ExitCode +toExitCode' = + runIdentity . toExitCode + +-- | Apply a natural transformation to the base functor. +-- +-- >>> hoistExitcode (Just . runIdentity) (mkExitSuccess' "abc") :: Exitcode () Maybe String +-- Exitcode (Just (Right "abc")) +{-# INLINE hoistExitcode #-} +hoistExitcode :: + (forall x. f x -> g x) -> + Exitcode e f a -> + Exitcode e g a +hoistExitcode nat (Exitcode x) = + Exitcode (nat x) + +-- | Embed a natural transformation that returns an @Exitcode@. +-- +-- >>> embedExitcode (\(Identity a) -> mkExitSuccess (Just a)) (mkExitSuccess' "abc") :: Exitcode () Maybe String +-- Exitcode (Just (Right "abc")) +-- >>> embedExitcode (\(Identity a) -> mkExitSuccess (Just a)) (mkExitFailure1' ()) :: Exitcode () Maybe () +-- Exitcode (Just (Left ((),NotZero True (Positive 1)))) +{-# INLINE embedExitcode #-} +embedExitcode :: + (Functor g) => + (forall x. f x -> Exitcode e g x) -> + Exitcode e f a -> + Exitcode e g a +embedExitcode nat (Exitcode x) = + Exitcode (join <$> runExitcode (nat x)) + +-- | Map both the error and success values via @Bifunctor@ on @ExitcodeBifunctor@. +-- +-- >>> bimapExitcode (+1) (+10) (mkExitFailure1' 5 :: Exitcode' Int Int) +-- Exitcode (Identity (Left (6,NotZero True (Positive 1)))) +-- >>> bimapExitcode (+1) (+10) (mkExitSuccess' 5 :: Exitcode' Int Int) +-- Exitcode (Identity (Right 15)) +{-# INLINE bimapExitcode #-} +bimapExitcode :: + (Functor f) => + (e -> e') -> + (a -> a') -> + Exitcode e f a -> + Exitcode e' f a' +bimapExitcode f g (Exitcode x) = + Exitcode (fmap (either (\(e, n) -> Left (f e, n)) (Right . g)) x) + +-- * Exceptions + +-- | Try the IO action producing the exitcode, catching exceptions into @ExceptT@. +{-# INLINE tryExitcode #-} +tryExitcode :: + (Exception e') => + Exitcode e IO a -> + Exitcode e (ExceptT e' IO) a +tryExitcode (Exitcode x) = + Exitcode (ExceptT (try x)) + +-- | Lift an IO action into @Exitcode (ExceptT e' IO)@, catching exceptions. +{-# INLINE liftTryExitcode #-} +liftTryExitcode :: + (Exception e') => + IO a -> + Exitcode e (ExceptT e' IO) a +liftTryExitcode x = + Exitcode (ExceptT (fmap (fmap Right) (try x))) + +-- * RULES + +{-# INLINE [0] exitcodeMap #-} +exitcodeMap :: (Functor f) => (a -> b) -> Exitcode e f a -> Exitcode e f b +exitcodeMap f (Exitcode x) = Exitcode (fmap (fmap f) x) + +{-# INLINE [0] exitcodeFoldMap #-} +exitcodeFoldMap :: (Foldable f, Monoid m) => (a -> m) -> Exitcode e f a -> m +exitcodeFoldMap f (Exitcode x) = foldMap (either (const mempty) f) x + +{-# RULES +"exitcodeMap/exitcodeMap" [~0] forall f g xs. + exitcodeMap f (exitcodeMap g xs) = + exitcodeMap (f . g) xs +"exitcodeFoldMap/exitcodeMap" [~0] forall f g xs. + exitcodeFoldMap f (exitcodeMap g xs) = + exitcodeFoldMap (f . g) xs + #-} + +-- * Exitcode Instances + +-- | +-- +-- >>> fmap (+1) (mkExitSuccess' 3) :: Exitcode' () Int +-- Exitcode (Identity (Right 4)) +-- >>> fmap (+1) (mkExitFailure1' ()) :: Exitcode' () Int +-- Exitcode (Identity (Left ((),NotZero True (Positive 1)))) +instance (Functor f) => Functor (Exitcode e f) where + {-# INLINE fmap #-} + fmap = exitcodeMap + +-- | +-- +-- >>> foldMap show (mkExitSuccess' 42) :: String +-- "42" +-- >>> foldMap show (mkExitFailure1' () :: Exitcode' () Int) :: String +-- "" +instance (Foldable f) => Foldable (Exitcode e f) where + {-# INLINE foldMap #-} + foldMap = exitcodeFoldMap + +-- | +-- +-- >>> traverse Just (mkExitSuccess' 42) :: Maybe (Exitcode' () Int) +-- Just (Exitcode (Identity (Right 42))) +-- >>> traverse (const Nothing) (mkExitSuccess' 42) :: Maybe (Exitcode' () Int) +-- Nothing +-- >>> traverse Just (mkExitFailure1' () :: Exitcode' () Int) :: Maybe (Exitcode' () Int) +-- Just (Exitcode (Identity (Left ((),NotZero True (Positive 1))))) +instance (Traversable f) => Traversable (Exitcode e f) where + {-# INLINE traverse #-} + traverse f (Exitcode x) = + Exitcode <$> traverse (either (pure . Left) (fmap Right . f)) x + +-- | +-- +-- >>> imap (\_ a -> a + 1) (mkExitSuccess' 3) :: Exitcode' () Int +-- Exitcode (Identity (Right 4)) +instance (FunctorWithIndex i f) => FunctorWithIndex i (Exitcode e f) where + {-# INLINE imap #-} + imap f (Exitcode x) = Exitcode (imap (\i -> fmap (f i)) x) + +-- | +-- +-- >>> ifoldMap (\_ a -> show a) (mkExitSuccess' 42) :: String +-- "42" +instance (FoldableWithIndex i f) => FoldableWithIndex i (Exitcode e f) where + {-# INLINE ifoldMap #-} + ifoldMap f (Exitcode x) = ifoldMap (\i -> either (const mempty) (f i)) x + +-- | +-- +-- >>> itraverse (\_ a -> Just (a + 1)) (mkExitSuccess' 42) :: Maybe (Exitcode' () Int) +-- Just (Exitcode (Identity (Right 43))) +instance (TraversableWithIndex i f) => TraversableWithIndex i (Exitcode e f) where + {-# INLINE itraverse #-} + itraverse f (Exitcode x) = Exitcode <$> itraverse (\i -> either (pure . Left) (fmap Right . f i)) x + +-- | +-- +-- >>> mkExitSuccess' (+1) <*> mkExitSuccess' 3 :: Exitcode' () Int +-- Exitcode (Identity (Right 4)) +-- >>> mkExitFailure1' () <*> mkExitSuccess' 3 :: Exitcode' () Int +-- Exitcode (Identity (Left ((),NotZero True (Positive 1)))) +instance (Monad f) => Apply (Exitcode e f) where + {-# INLINE (<.>) #-} + Exitcode f <.> Exitcode a = + Exitcode (f >>= either (pure . Left) (\f' -> fmap (fmap f') a)) + +-- | +-- +-- >>> pure 42 :: Exitcode' () Int +-- Exitcode (Identity (Right 42)) +-- >>> mkExitSuccess' (+1) <*> mkExitSuccess' 3 :: Exitcode' () Int +-- Exitcode (Identity (Right 4)) +-- >>> mkExitFailure1' () <*> mkExitSuccess' 3 :: Exitcode' () Int +-- Exitcode (Identity (Left ((),NotZero True (Positive 1)))) +instance (Monad f) => Applicative (Exitcode e f) where + {-# INLINE pure #-} + pure = Exitcode . pure . Right + {-# INLINE (<*>) #-} + Exitcode f <*> Exitcode a = + Exitcode (f >>= either (pure . Left) (\f' -> fmap (fmap f') a)) + +-- | +-- +-- >>> mkExitSuccess' 3 >>- (\x -> mkExitSuccess' (x + 1)) :: Exitcode' () Int +-- Exitcode (Identity (Right 4)) +instance (Monad f) => Bind (Exitcode e f) where + {-# INLINE (>>-) #-} + (>>-) = (>>=) + +-- | +-- +-- >>> mkExitSuccess' 3 >>= (\x -> mkExitSuccess' (x + 1)) :: Exitcode' () Int +-- Exitcode (Identity (Right 4)) +-- >>> mkExitFailure1' () >>= (\x -> mkExitSuccess' (x + 1)) :: Exitcode' () Int +-- Exitcode (Identity (Left ((),NotZero True (Positive 1)))) +instance (Monad f) => Monad (Exitcode e f) where + {-# INLINE (>>=) #-} + Exitcode x >>= f = + Exitcode (x >>= either (pure . Left) (runExitcode . f)) + +-- | +-- +-- >>> import Control.Monad.Fix (mfix) +-- >>> runExitcode (mfix (const (mkExitSuccess' 42)) :: Exitcode' () Int) +-- Identity (Right 42) +-- >>> runExitcode (mfix (const (mkExitFailure1' ())) :: Exitcode' () Int) +-- Identity (Left ((),NotZero True (Positive 1))) +instance (MonadFix f) => MonadFix (Exitcode e f) where + {-# INLINE mfix #-} + mfix f = Exitcode (mfix (runExitcode . f . either (const (let a = a in a)) id)) + +-- | +-- +-- >>> mkExitFailure1' () mkExitSuccess' 42 :: Exitcode' () Int +-- Exitcode (Identity (Right 42)) +-- >>> mkExitSuccess' 1 mkExitSuccess' 2 :: Exitcode' () Int +-- Exitcode (Identity (Right 1)) +instance (Monad f) => Alt (Exitcode e f) where + {-# INLINE () #-} + Exitcode a Exitcode b = + Exitcode (a >>= either (const b) (pure . Right)) + +-- | +-- +-- >>> mkExitSuccess' "abc" <> mkExitSuccess' "def" :: Exitcode' () String +-- Exitcode (Identity (Right "abcdef")) +-- >>> mkExitSuccess' "abc" <> mkExitFailure1' () :: Exitcode' () String +-- Exitcode (Identity (Right "abc")) +-- >>> mkExitFailure1' () <> mkExitSuccess' "def" :: Exitcode' () String +-- Exitcode (Identity (Right "def")) +-- >>> (mkExitFailure1' () :: Exitcode' () String) <> mkExitFailure_1' () +-- Exitcode (Identity (Left ((),NotZero False (Positive 1)))) +instance (Semigroup a, Monad f) => Semigroup (Exitcode e f a) where + {-# INLINE (<>) #-} + Exitcode a <> Exitcode b = + Exitcode + ( a + >>= either + (\_ -> b >>= either (pure . Left) (pure . Right)) + (\a1 -> b >>= either (\_ -> pure (Right a1)) (\a2 -> pure (Right (a1 <> a2)))) + ) + +-- | +-- +-- >>> mempty :: Exitcode' () String +-- Exitcode (Identity (Right "")) +instance (Monoid a, Monad f) => Monoid (Exitcode e f a) where + {-# INLINE mempty #-} + mempty = Exitcode (pure (Right mempty)) + +-- | +-- +-- >>> duplicated (mkExitFailure1' ()) :: Exitcode' () (Exitcode' () ()) +-- Exitcode (Identity (Right (Exitcode (Identity (Left ((),NotZero True (Positive 1))))))) +-- >>> duplicated (mkExitSuccess' "abc") :: Exitcode' () (Exitcode' () String) +-- Exitcode (Identity (Right (Exitcode (Identity (Right "abc"))))) +instance (Extend f) => Extend (Exitcode e f) where + {-# INLINE duplicated #-} + duplicated (Exitcode x) = + Exitcode (extended (Right . Exitcode) x) + +-- | +-- +-- >>> mkExitSuccess' 1 == mkExitSuccess' 1 :: Bool +-- True +-- >>> mkExitSuccess' 1 == (mkExitFailure1' () :: Exitcode' () Int) :: Bool +-- False +instance (Eq (f (Either (e, NotZero) a))) => Eq (Exitcode e f a) where + {-# INLINE (==) #-} + Exitcode a == Exitcode b = a == b + +-- | +-- +-- >>> liftEq (==) (mkExitSuccess' 1) (mkExitSuccess' 1 :: Exitcode' () Int) +-- True +-- >>> liftEq (==) (mkExitSuccess' 1) (mkExitSuccess' 2 :: Exitcode' () Int) +-- False +instance (Eq1 f, Eq e) => Eq1 (Exitcode e f) where + {-# INLINE liftEq #-} + liftEq f (Exitcode a) (Exitcode b) = + liftEq (liftEq f) a b + +-- | +-- +-- >>> compare (mkExitSuccess' 1 :: Exitcode' () Int) (mkExitSuccess' 2) +-- LT +-- >>> compare (mkExitSuccess' 1 :: Exitcode' () Int) (mkExitFailure1' ()) +-- GT +instance (Ord (f (Either (e, NotZero) a))) => Ord (Exitcode e f a) where + {-# INLINE compare #-} + Exitcode a `compare` Exitcode b = compare a b + +-- | +-- +-- >>> liftCompare compare (mkExitSuccess' 1) (mkExitSuccess' 2 :: Exitcode' () Int) +-- LT +instance (Ord1 f, Ord e) => Ord1 (Exitcode e f) where + {-# INLINE liftCompare #-} + liftCompare f (Exitcode a) (Exitcode b) = + liftCompare (liftCompare f) a b + +-- | +-- +-- >>> show (mkExitSuccess' "abc" :: Exitcode' () String) +-- "Exitcode (Identity (Right \"abc\"))" +-- >>> show (mkExitFailure1' 'x' :: Exitcode' Char ()) +-- "Exitcode (Identity (Left ('x',NotZero True (Positive 1))))" +instance (Show (f (Either (e, NotZero) a))) => Show (Exitcode e f a) where + {-# INLINE showsPrec #-} + showsPrec d (Exitcode m) = + showParen (d > 10) $ + showString "Exitcode " . showsPrec 11 m + +-- | +-- +-- >>> liftShowsPrec showsPrec showList 0 (mkExitSuccess' 42 :: Exitcode' () Int) "" +-- "Exitcode (Identity (Right 42))" +instance (Show1 f, Show e) => Show1 (Exitcode e f) where + {-# INLINE liftShowsPrec #-} + liftShowsPrec sp sl d (Exitcode fa) = + showParen (d > 10) $ + showString "Exitcode " + . liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl) 11 fa + +instance (NFData1 f, NFData e, NFData a) => NFData (Exitcode e f a) where + {-# INLINE rnf #-} + rnf = liftRnf rnf + +instance (NFData1 f, NFData e) => NFData1 (Exitcode e f) where + {-# INLINE liftRnf #-} + liftRnf r (Exitcode x) = liftRnf rnfEither x + where + rnfEither (Right a) = r a + rnfEither (Left (e, n)) = rnf e `seq` rnf (review _NotZero n :: Int) + +-- | +-- +-- >>> import Control.Monad.IO.Class (liftIO) +-- >>> runExitcode (liftIO (pure 42) :: Exitcode () IO Int) +-- Right 42 +instance (MonadIO f) => MonadIO (Exitcode e f) where + {-# INLINE liftIO #-} + liftIO io = Exitcode (Right <$> liftIO io) + +-- | +-- +-- >>> import Control.Monad.Reader (runReader) +-- >>> runReader (runExitcode (ask :: Exitcode () (Control.Monad.Reader.Reader Int) Int)) 42 +-- Right 42 +-- >>> runReader (runExitcode (local (+1) ask :: Exitcode () (Control.Monad.Reader.Reader Int) Int)) 42 +-- Right 43 +instance (MonadReader r f) => MonadReader r (Exitcode e f) where + {-# INLINE ask #-} + ask = Exitcode (asks Right) + {-# INLINE local #-} + local f (Exitcode m) = Exitcode (local f m) + +-- | +-- +-- >>> import Control.Monad.Writer (runWriter) +-- >>> runWriter (runExitcode (tell "hello" :: Exitcode () (Control.Monad.Writer.Lazy.Writer String) ())) +-- (Right (),"hello") +instance (MonadWriter w f) => MonadWriter w (Exitcode e f) where + {-# INLINE writer #-} + writer t = Exitcode . fmap pure $ writer t + {-# INLINE listen #-} + listen (Exitcode m) = Exitcode ((\(e, w) -> (,w) <$> e) <$> listen m) + {-# INLINE tell #-} + tell = Exitcode . fmap Right . tell + {-# INLINE pass #-} + pass e = + do + ((a, f), w) <- listen e + tell (f w) + pure a + +-- | +-- +-- >>> import Control.Monad.State (runState) +-- >>> runState (runExitcode (get :: Exitcode () (Control.Monad.State.Lazy.State Int) Int)) 7 +-- (Right 7,7) +-- >>> runState (runExitcode (put 99 :: Exitcode () (Control.Monad.State.Lazy.State Int) ())) 7 +-- (Right (),99) +instance (MonadState s f) => MonadState s (Exitcode e f) where + {-# INLINE get #-} + get = Exitcode (fmap Right get) + {-# INLINE put #-} + put = Exitcode . fmap Right . put + +-- | @throwError@ and @catchError@ operate on the error channel of the base +-- functor @f@, not on the exit code failure. +-- +-- >>> import Control.Monad.Except (runExcept) +-- >>> runExcept (runExitcode (throwError "oops" :: Exitcode () (Control.Monad.Except.Except String) Int)) +-- Left "oops" +instance (MonadError e f) => MonadError e (Exitcode e' f) where + {-# INLINE throwError #-} + throwError = Exitcode . fmap Right . throwError + {-# INLINE catchError #-} + catchError (Exitcode f) h = Exitcode (catchError f (runExitcode . h)) + +instance (MonadRWS r w s f) => MonadRWS r w s (Exitcode e f) + +-- | +-- +-- >>> import Control.Monad.Cont (runCont) +-- >>> runCont (runExitcode (callCC (\k -> k 42) :: Exitcode () (Control.Monad.Cont.Cont (Either ((), NotZero) Int)) Int)) id +-- Right 42 +instance (MonadCont f) => MonadCont (Exitcode e f) where + callCC f = + Exitcode (callCC (\c -> runExitcode (f (Exitcode . c . Right)))) + +-- | +-- +-- >>> import Control.Monad.Trans.Class (lift) +-- >>> runExitcode (lift (Identity 42) :: Exitcode' () Int) +-- Identity (Right 42) +instance MonadTrans (Exitcode e) where + {-# INLINE lift #-} + lift = Exitcode . fmap Right + +-- | +-- +-- >>> import Data.Functor.Bind.Trans (liftB) +-- >>> runExitcode (liftB (Identity 42) :: Exitcode' () Int) +-- Identity (Right 42) +instance BindTrans (Exitcode e) where + {-# INLINE liftB #-} + liftB = Exitcode . fmap Right + +-- * ExitcodeBifunctor + +-- | @ExitcodeBifunctor@ reorders the type parameters of @Exitcode@ so that +-- @e@ and @a@ are last, enabling @Bifunctor@, @Bifoldable@, and @Bitraversable@ +-- instances. +newtype ExitcodeBifunctor f e a = ExitcodeBifunctor (Exitcode e f a) + deriving stock (Generic) + +-- | @ExitcodeBifunctor@ specialised to @Identity@. +type ExitcodeBifunctor' e a = ExitcodeBifunctor Identity e a + +-- * ExitcodeBifunctor Instances + +-- | +-- +-- >>> bimap (+1) (+10) (ExitcodeBifunctor (mkExitFailure1' 5) :: ExitcodeBifunctor' Int Int) +-- ExitcodeBifunctor (Exitcode (Identity (Left (6,NotZero True (Positive 1))))) +-- >>> bimap (+1) (+10) (ExitcodeBifunctor (mkExitSuccess' 5) :: ExitcodeBifunctor' Int Int) +-- ExitcodeBifunctor (Exitcode (Identity (Right 15))) +instance (Functor f) => Bifunctor (ExitcodeBifunctor f) where + {-# INLINE bimap #-} + bimap f g (ExitcodeBifunctor x) = ExitcodeBifunctor (bimapExitcode f g x) + +-- | +-- +-- >>> bifoldMap show show (ExitcodeBifunctor (mkExitFailure1' 'x') :: ExitcodeBifunctor' Char Int) +-- "'x'" +-- >>> bifoldMap show show (ExitcodeBifunctor (mkExitSuccess' 42) :: ExitcodeBifunctor' Char Int) +-- "42" +instance (Foldable f) => Bifoldable (ExitcodeBifunctor f) where + {-# INLINE bifoldMap #-} + bifoldMap f g (ExitcodeBifunctor (Exitcode x)) = + foldMap (either (\(e, _) -> f e) g) x + +-- | +-- +-- >>> bitraverse (Just . (+1)) (Just . (+10)) (ExitcodeBifunctor (mkExitFailure1' 5) :: ExitcodeBifunctor' Int Int) +-- Just (ExitcodeBifunctor (Exitcode (Identity (Left (6,NotZero True (Positive 1)))))) +-- >>> bitraverse (Just . (+1)) (Just . (+10)) (ExitcodeBifunctor (mkExitSuccess' 5) :: ExitcodeBifunctor' Int Int) +-- Just (ExitcodeBifunctor (Exitcode (Identity (Right 15)))) +instance (Traversable f) => Bitraversable (ExitcodeBifunctor f) where + {-# INLINE bitraverse #-} + bitraverse f g (ExitcodeBifunctor (Exitcode x)) = + ExitcodeBifunctor . Exitcode <$> traverse (either (\(e, n) -> fmap (\e' -> Left (e', n)) (f e)) (fmap Right . g)) x + +-- | +-- +-- >>> fmap (+1) (ExitcodeBifunctor (mkExitSuccess' 3) :: ExitcodeBifunctor' () Int) +-- ExitcodeBifunctor (Exitcode (Identity (Right 4))) +instance (Functor f) => Functor (ExitcodeBifunctor f e) where + {-# INLINE fmap #-} + fmap f (ExitcodeBifunctor x) = ExitcodeBifunctor (fmap f x) + +-- | +-- +-- >>> foldMap show (ExitcodeBifunctor (mkExitSuccess' 42) :: ExitcodeBifunctor' () Int) +-- "42" +instance (Foldable f) => Foldable (ExitcodeBifunctor f e) where + {-# INLINE foldMap #-} + foldMap f (ExitcodeBifunctor x) = foldMap f x + +-- | +-- +-- >>> traverse Just (ExitcodeBifunctor (mkExitSuccess' 42) :: ExitcodeBifunctor' () Int) +-- Just (ExitcodeBifunctor (Exitcode (Identity (Right 42)))) +instance (Traversable f) => Traversable (ExitcodeBifunctor f e) where + {-# INLINE traverse #-} + traverse f (ExitcodeBifunctor x) = ExitcodeBifunctor <$> traverse f x + +instance (FunctorWithIndex i f) => FunctorWithIndex i (ExitcodeBifunctor f e) where + {-# INLINE imap #-} + imap f (ExitcodeBifunctor x) = ExitcodeBifunctor (imap f x) + +instance (FoldableWithIndex i f) => FoldableWithIndex i (ExitcodeBifunctor f e) where + {-# INLINE ifoldMap #-} + ifoldMap f (ExitcodeBifunctor x) = ifoldMap f x + +instance (TraversableWithIndex i f) => TraversableWithIndex i (ExitcodeBifunctor f e) where + {-# INLINE itraverse #-} + itraverse f (ExitcodeBifunctor x) = ExitcodeBifunctor <$> itraverse f x + +instance (Monad f) => Apply (ExitcodeBifunctor f e) where + {-# INLINE (<.>) #-} + ExitcodeBifunctor f <.> ExitcodeBifunctor a = ExitcodeBifunctor (f <.> a) + +-- | +-- +-- >>> pure 42 :: ExitcodeBifunctor' () Int +-- ExitcodeBifunctor (Exitcode (Identity (Right 42))) +instance (Monad f) => Applicative (ExitcodeBifunctor f e) where + {-# INLINE pure #-} + pure = ExitcodeBifunctor . pure + {-# INLINE (<*>) #-} + ExitcodeBifunctor f <*> ExitcodeBifunctor a = ExitcodeBifunctor (f <*> a) + +instance (Monad f) => Bind (ExitcodeBifunctor f e) where + {-# INLINE (>>-) #-} + (>>-) = (>>=) + +instance (Monad f) => Monad (ExitcodeBifunctor f e) where + {-# INLINE (>>=) #-} + ExitcodeBifunctor x >>= f = ExitcodeBifunctor (x >>= (\a -> let ExitcodeBifunctor y = f a in y)) + +instance (MonadFix f) => MonadFix (ExitcodeBifunctor f e) where + {-# INLINE mfix #-} + mfix f = ExitcodeBifunctor (mfix (\a -> let ExitcodeBifunctor y = f a in y)) + +-- | +-- +-- >>> (ExitcodeBifunctor (mkExitFailure1' ()) :: ExitcodeBifunctor' () Int) ExitcodeBifunctor (mkExitSuccess' 42) +-- ExitcodeBifunctor (Exitcode (Identity (Right 42))) +instance (Monad f) => Alt (ExitcodeBifunctor f e) where + {-# INLINE () #-} + ExitcodeBifunctor a ExitcodeBifunctor b = ExitcodeBifunctor (a b) + +instance (Semigroup a, Monad f) => Semigroup (ExitcodeBifunctor f e a) where + {-# INLINE (<>) #-} + ExitcodeBifunctor a <> ExitcodeBifunctor b = ExitcodeBifunctor (a <> b) + +instance (Monoid a, Monad f) => Monoid (ExitcodeBifunctor f e a) where + {-# INLINE mempty #-} + mempty = ExitcodeBifunctor mempty + +instance (Extend f) => Extend (ExitcodeBifunctor f e) where + {-# INLINE duplicated #-} + duplicated (ExitcodeBifunctor x) = ExitcodeBifunctor (fmap ExitcodeBifunctor (duplicated x)) + +instance (Eq (f (Either (e, NotZero) a))) => Eq (ExitcodeBifunctor f e a) where + {-# INLINE (==) #-} + ExitcodeBifunctor (Exitcode a) == ExitcodeBifunctor (Exitcode b) = a == b + +instance (Eq1 f, Eq e) => Eq1 (ExitcodeBifunctor f e) where + {-# INLINE liftEq #-} + liftEq f (ExitcodeBifunctor (Exitcode a)) (ExitcodeBifunctor (Exitcode b)) = + liftEq (liftEq f) a b + +instance (Ord (f (Either (e, NotZero) a))) => Ord (ExitcodeBifunctor f e a) where + {-# INLINE compare #-} + ExitcodeBifunctor (Exitcode a) `compare` ExitcodeBifunctor (Exitcode b) = compare a b + +instance (Ord1 f, Ord e) => Ord1 (ExitcodeBifunctor f e) where + {-# INLINE liftCompare #-} + liftCompare f (ExitcodeBifunctor (Exitcode a)) (ExitcodeBifunctor (Exitcode b)) = + liftCompare (liftCompare f) a b + +-- | +-- +-- >>> show (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- "ExitcodeBifunctor (Exitcode (Identity (Right \"abc\")))" +-- >>> show (ExitcodeBifunctor (mkExitFailure1' 'x') :: ExitcodeBifunctor' Char ()) +-- "ExitcodeBifunctor (Exitcode (Identity (Left ('x',NotZero True (Positive 1)))))" +instance (Show (f (Either (e, NotZero) a))) => Show (ExitcodeBifunctor f e a) where + {-# INLINE showsPrec #-} + showsPrec d (ExitcodeBifunctor (Exitcode m)) = + showParen (d > 10) $ + showString "ExitcodeBifunctor (Exitcode " . showsPrec 11 m . showString ")" + +instance (Show1 f, Show e) => Show1 (ExitcodeBifunctor f e) where + {-# INLINE liftShowsPrec #-} + liftShowsPrec sp sl d (ExitcodeBifunctor (Exitcode fa)) = + showParen (d > 10) $ + showString "ExitcodeBifunctor (Exitcode " + . liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl) 11 fa + . showString ")" + +instance (NFData1 f, NFData e, NFData a) => NFData (ExitcodeBifunctor f e a) where + {-# INLINE rnf #-} + rnf = liftRnf rnf + +instance (NFData1 f, NFData e) => NFData1 (ExitcodeBifunctor f e) where + {-# INLINE liftRnf #-} + liftRnf r (ExitcodeBifunctor (Exitcode x)) = liftRnf rnfEither x + where + rnfEither (Right a) = r a + rnfEither (Left (e, n)) = rnf e `seq` rnf (review _NotZero n :: Int) + +instance (MonadIO f) => MonadIO (ExitcodeBifunctor f e) where + {-# INLINE liftIO #-} + liftIO = ExitcodeBifunctor . liftIO + +instance (MonadReader r f) => MonadReader r (ExitcodeBifunctor f e) where + {-# INLINE ask #-} + ask = ExitcodeBifunctor ask + {-# INLINE local #-} + local f (ExitcodeBifunctor x) = ExitcodeBifunctor (local f x) + +instance (MonadWriter w f) => MonadWriter w (ExitcodeBifunctor f e) where + {-# INLINE writer #-} + writer t = ExitcodeBifunctor (writer t) + {-# INLINE listen #-} + listen (ExitcodeBifunctor x) = ExitcodeBifunctor (listen x) + {-# INLINE tell #-} + tell = ExitcodeBifunctor . tell + {-# INLINE pass #-} + pass (ExitcodeBifunctor x) = ExitcodeBifunctor (pass x) + +instance (MonadState s f) => MonadState s (ExitcodeBifunctor f e) where + {-# INLINE get #-} + get = ExitcodeBifunctor get + {-# INLINE put #-} + put = ExitcodeBifunctor . put + +instance (MonadError e f) => MonadError e (ExitcodeBifunctor f e') where + {-# INLINE throwError #-} + throwError = ExitcodeBifunctor . throwError + {-# INLINE catchError #-} + catchError (ExitcodeBifunctor x) h = ExitcodeBifunctor (catchError x (\e -> let ExitcodeBifunctor y = h e in y)) + +instance (MonadRWS r w s f) => MonadRWS r w s (ExitcodeBifunctor f e) + +instance (MonadCont f) => MonadCont (ExitcodeBifunctor f e) where + callCC f = ExitcodeBifunctor (callCC (\c -> let ExitcodeBifunctor x = f (ExitcodeBifunctor . c) in x)) + diff --git a/src/Control/Exitcode/Optics.hs b/src/Control/Exitcode/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exitcode/Optics.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +module Control.Exitcode.Optics + ( GetExitcode (..), + HasExitcode (..), + ReviewExitcode (..), + AsExitcode (..), + GetExitcodeBifunctor (..), + HasExitcodeBifunctor (..), + ReviewExitcodeBifunctor (..), + AsExitcodeBifunctor (..), + ) +where + +import Control.Category (id, (.)) +import Control.Exitcode.Exitcode (Exitcode, ExitcodeBifunctor (ExitcodeBifunctor)) +import Control.Lens (Getter, Lens', Prism', Review, lens, prism', unto) +import Data.Maybe (Maybe (Just)) + +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens +-- >>> import Control.Exitcode + +-- * Exitcode optics + +-- | Type class for values that can be viewed as an @Exitcode@. +-- +-- >>> view getExitcode (mkExitSuccess' "abc" :: Exitcode' () String) :: Exitcode' () String +-- Exitcode (Identity (Right "abc")) +class GetExitcode s e f a | s -> e f a where + getExitcode :: Getter s (Exitcode e f a) + +-- | +-- +-- >>> view getExitcode (mkExitSuccess' "abc" :: Exitcode' () String) +-- Exitcode (Identity (Right "abc")) +instance GetExitcode (Exitcode e f a) e f a where + getExitcode = id + {-# INLINE getExitcode #-} + +-- | +-- +-- >>> view getExitcode (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- Exitcode (Identity (Right "abc")) +instance GetExitcode (ExitcodeBifunctor f e a) e f a where + getExitcode = lens (\(ExitcodeBifunctor x) -> x) (\_ -> ExitcodeBifunctor) + {-# INLINE getExitcode #-} + +-- | Type class for values with a lens into an @Exitcode@. +-- +-- >>> view exitcode (mkExitSuccess' "abc" :: Exitcode' () String) +-- Exitcode (Identity (Right "abc")) +class (GetExitcode s e f a) => HasExitcode s e f a | s -> e f a where + exitcode :: Lens' s (Exitcode e f a) + +-- | +-- +-- >>> view exitcode (mkExitSuccess' "abc" :: Exitcode' () String) +-- Exitcode (Identity (Right "abc")) +instance HasExitcode (Exitcode e f a) e f a where + exitcode = id + {-# INLINE exitcode #-} + +-- | +-- +-- >>> view exitcode (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- Exitcode (Identity (Right "abc")) +-- >>> set exitcode (mkExitFailure1' ()) (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- ExitcodeBifunctor (Exitcode (Identity (Left ((),NotZero True (Positive 1))))) +instance HasExitcode (ExitcodeBifunctor f e a) e f a where + exitcode = lens (\(ExitcodeBifunctor x) -> x) (\_ x -> ExitcodeBifunctor x) + {-# INLINE exitcode #-} + +-- | Type class for values that can be constructed from an @Exitcode@. +-- +-- >>> review reviewExitcode (mkExitSuccess' "abc" :: Exitcode' () String) :: Exitcode' () String +-- Exitcode (Identity (Right "abc")) +class ReviewExitcode t e f a | t -> e f a where + reviewExitcode :: Review t (Exitcode e f a) + +-- | +-- +-- >>> review reviewExitcode (mkExitSuccess' "abc" :: Exitcode' () String) :: Exitcode' () String +-- Exitcode (Identity (Right "abc")) +instance ReviewExitcode (Exitcode e f a) e f a where + reviewExitcode = unto id + {-# INLINE reviewExitcode #-} + +-- | +-- +-- >>> review reviewExitcode (mkExitSuccess' "abc" :: Exitcode' () String) :: ExitcodeBifunctor' () String +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +instance ReviewExitcode (ExitcodeBifunctor f e a) e f a where + reviewExitcode = unto ExitcodeBifunctor + {-# INLINE reviewExitcode #-} + +-- | Type class for values with a prism into an @Exitcode@. +-- +-- >>> preview _Exitcode (mkExitSuccess' "abc" :: Exitcode' () String) :: Maybe (Exitcode' () String) +-- Just (Exitcode (Identity (Right "abc"))) +class (ReviewExitcode t e f a) => AsExitcode t e f a | t -> e f a where + _Exitcode :: Prism' t (Exitcode e f a) + +-- | +-- +-- >>> preview _Exitcode (mkExitSuccess' "abc" :: Exitcode' () String) :: Maybe (Exitcode' () String) +-- Just (Exitcode (Identity (Right "abc"))) +instance AsExitcode (Exitcode e f a) e f a where + _Exitcode = id + {-# INLINE _Exitcode #-} + +-- | +-- +-- >>> preview _Exitcode (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) :: Maybe (Exitcode' () String) +-- Just (Exitcode (Identity (Right "abc"))) +instance AsExitcode (ExitcodeBifunctor f e a) e f a where + _Exitcode = prism' ExitcodeBifunctor (\(ExitcodeBifunctor x) -> Just x) + {-# INLINE _Exitcode #-} + +-- * ExitcodeBifunctor optics + +-- | Type class for values that can be viewed as an @ExitcodeBifunctor@. +-- +-- >>> view getExitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +class GetExitcodeBifunctor s f e a | s -> f e a where + getExitcodeBifunctor :: Getter s (ExitcodeBifunctor f e a) + +-- | +-- +-- >>> view getExitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +instance GetExitcodeBifunctor (ExitcodeBifunctor f e a) f e a where + getExitcodeBifunctor = id + {-# INLINE getExitcodeBifunctor #-} + +-- | +-- +-- >>> view getExitcodeBifunctor (mkExitSuccess' "abc" :: Exitcode' () String) +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +instance GetExitcodeBifunctor (Exitcode e f a) f e a where + getExitcodeBifunctor = lens ExitcodeBifunctor (\_ (ExitcodeBifunctor x) -> x) + {-# INLINE getExitcodeBifunctor #-} + +-- | Type class for values with a lens into an @ExitcodeBifunctor@. +-- +-- >>> view exitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +class (GetExitcodeBifunctor s f e a) => HasExitcodeBifunctor s f e a | s -> f e a where + exitcodeBifunctor :: Lens' s (ExitcodeBifunctor f e a) + +-- | +-- +-- >>> view exitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +instance HasExitcodeBifunctor (ExitcodeBifunctor f e a) f e a where + exitcodeBifunctor = id + {-# INLINE exitcodeBifunctor #-} + +-- | +-- +-- >>> view exitcodeBifunctor (mkExitSuccess' "abc" :: Exitcode' () String) +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +-- >>> set exitcodeBifunctor (ExitcodeBifunctor (mkExitFailure1' ())) (mkExitSuccess' "abc" :: Exitcode' () String) +-- Exitcode (Identity (Left ((),NotZero True (Positive 1)))) +instance HasExitcodeBifunctor (Exitcode e f a) f e a where + exitcodeBifunctor = lens ExitcodeBifunctor (\_ (ExitcodeBifunctor x) -> x) + {-# INLINE exitcodeBifunctor #-} + +-- | Type class for values that can be constructed from an @ExitcodeBifunctor@. +-- +-- >>> review reviewExitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) :: ExitcodeBifunctor' () String +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +class ReviewExitcodeBifunctor t f e a | t -> f e a where + reviewExitcodeBifunctor :: Review t (ExitcodeBifunctor f e a) + +-- | +-- +-- >>> review reviewExitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) :: ExitcodeBifunctor' () String +-- ExitcodeBifunctor (Exitcode (Identity (Right "abc"))) +instance ReviewExitcodeBifunctor (ExitcodeBifunctor f e a) f e a where + reviewExitcodeBifunctor = unto id + {-# INLINE reviewExitcodeBifunctor #-} + +-- | +-- +-- >>> review reviewExitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) :: Exitcode' () String +-- Exitcode (Identity (Right "abc")) +instance ReviewExitcodeBifunctor (Exitcode e f a) f e a where + reviewExitcodeBifunctor = unto (\(ExitcodeBifunctor x) -> x) + {-# INLINE reviewExitcodeBifunctor #-} + +-- | Type class for values with a prism into an @ExitcodeBifunctor@. +-- +-- >>> preview _ExitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- Just (ExitcodeBifunctor (Exitcode (Identity (Right "abc")))) +class (ReviewExitcodeBifunctor t f e a) => AsExitcodeBifunctor t f e a | t -> f e a where + _ExitcodeBifunctor :: Prism' t (ExitcodeBifunctor f e a) + +-- | +-- +-- >>> preview _ExitcodeBifunctor (ExitcodeBifunctor (mkExitSuccess' "abc") :: ExitcodeBifunctor' () String) +-- Just (ExitcodeBifunctor (Exitcode (Identity (Right "abc")))) +instance AsExitcodeBifunctor (ExitcodeBifunctor f e a) f e a where + _ExitcodeBifunctor = id + {-# INLINE _ExitcodeBifunctor #-} + +-- | +-- +-- >>> preview _ExitcodeBifunctor (mkExitSuccess' "abc" :: Exitcode' () String) +-- Just (ExitcodeBifunctor (Exitcode (Identity (Right "abc")))) +instance AsExitcodeBifunctor (Exitcode e f a) f e a where + _ExitcodeBifunctor = prism' (\(ExitcodeBifunctor x) -> x) (Just . ExitcodeBifunctor) + {-# INLINE _ExitcodeBifunctor #-} diff --git a/src/Control/Process.hs b/src/Control/Process.hs --- a/src/Control/Process.hs +++ b/src/Control/Process.hs @@ -1,9 +1,10 @@ -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process( - module P -) where +module Control.Process + ( module P, + ) +where import Control.Process.CmdSpec as P import Control.Process.CreateProcess as P diff --git a/src/Control/Process/CmdSpec.hs b/src/Control/Process/CmdSpec.hs --- a/src/Control/Process/CmdSpec.hs +++ b/src/Control/Process/CmdSpec.hs @@ -1,97 +1,195 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.CmdSpec( - AsCmdSpec(..) -, HasCmdSpec(..) -) where +module Control.Process.CmdSpec + ( CmdSpec (..), + GetCmdSpec (..), + HasCmdSpec (..), + ReviewCmdSpec (..), + AsCmdSpec (..), + ) +where -import Control.Category ( Category(id, (.)) ) +import Control.Category (id, (.)) import Control.Lens - ( Traversable(traverse), - prism', - Field1(_1), - Field2(_2), - Lens', - Prism', - Traversal' ) -import Data.Maybe ( Maybe(Nothing, Just) ) -import Data.Functor ( Functor(fmap) ) -import Data.String ( String ) -import Data.Tuple ( uncurry ) -import System.FilePath ( FilePath ) -import System.Process ( CreateProcess(..), CmdSpec(..) ) + ( Field1 (_1), + Field2 (_2), + Getter, + Lens', + Prism', + Review, + Traversable (traverse), + Traversal', + prism', + to, + unto, + ) +import Data.Functor (Functor (fmap)) +import Data.Maybe (Maybe (Just, Nothing)) +import Data.String (String) +import Data.Tuple (uncurry) +import System.FilePath (FilePath) +import System.Process (CmdSpec (..), CreateProcess) +import qualified System.Process as Process (CreateProcess (..)) -class AsCmdSpec a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens + +-- | Type class for values that can be viewed as a @CmdSpec@. +-- +-- >>> view getCmdSpec (ShellCommand "ls -la") +-- ShellCommand "ls -la" +class GetCmdSpec a where + getCmdSpec :: + Getter a CmdSpec + +-- | +-- +-- >>> view getCmdSpec (ShellCommand "ls -la") +-- ShellCommand "ls -la" +instance GetCmdSpec CmdSpec where + getCmdSpec = id + {-# INLINE getCmdSpec #-} + +-- | +-- +-- >>> import System.Process (proc) +-- >>> view getCmdSpec (proc "echo" ["hello"]) +-- RawCommand "echo" ["hello"] +instance GetCmdSpec CreateProcess where + getCmdSpec = to Process.cmdspec + {-# INLINE getCmdSpec #-} + +-- | Type class for values with a lens into a @CmdSpec@. +-- +-- >>> view cmdSpec (ShellCommand "ls -la") +-- ShellCommand "ls -la" +class (GetCmdSpec a) => HasCmdSpec a where + cmdSpec :: + Lens' a CmdSpec + {-# INLINE shellCommand #-} + shellCommand :: + Traversal' a String + shellCommand = + cmdSpec . _ShellCommand + {-# INLINE rawCommand #-} + rawCommand :: + Traversal' a (FilePath, [String]) + rawCommand = + cmdSpec . _RawCommand + {-# INLINE rawCommandExe #-} + rawCommandExe :: + Traversal' a FilePath + rawCommandExe = + rawCommand . _1 + {-# INLINE rawCommandArgumentList #-} + rawCommandArgumentList :: + Traversal' a [String] + rawCommandArgumentList = + rawCommand . _2 + {-# INLINE rawCommandArguments #-} + rawCommandArguments :: + Traversal' a String + rawCommandArguments = + rawCommandArgumentList . traverse + +-- | +-- +-- >>> view cmdSpec (ShellCommand "ls") +-- ShellCommand "ls" +-- >>> set cmdSpec (RawCommand "echo" ["hi"]) (ShellCommand "ls") +-- RawCommand "echo" ["hi"] +instance HasCmdSpec CmdSpec where + cmdSpec = + id + +-- | +-- +-- >>> import System.Process (proc) +-- >>> view cmdSpec (proc "echo" ["hello"]) +-- RawCommand "echo" ["hello"] +instance HasCmdSpec CreateProcess where + cmdSpec f p = + fmap (\x -> p {Process.cmdspec = x}) (f (Process.cmdspec p)) + +-- | Type class for values that can be constructed from a @CmdSpec@. +-- +-- >>> review reviewCmdSpec (ShellCommand "ls") :: CmdSpec +-- ShellCommand "ls" +class ReviewCmdSpec a where + reviewCmdSpec :: + Review a CmdSpec + +-- | +-- +-- >>> review reviewCmdSpec (ShellCommand "ls") :: CmdSpec +-- ShellCommand "ls" +instance ReviewCmdSpec CmdSpec where + reviewCmdSpec = unto id + {-# INLINE reviewCmdSpec #-} + +-- | Type class for values with a prism into a @CmdSpec@. +-- +-- >>> preview _CmdSpec (ShellCommand "ls -la") +-- Just (ShellCommand "ls -la") +class (ReviewCmdSpec a) => AsCmdSpec a where _CmdSpec :: Prism' a CmdSpec + {-# INLINE _ShellCommand #-} _ShellCommand :: Prism' a String _ShellCommand = _CmdSpec . _ShellCommand + {-# INLINE _RawCommand #-} _RawCommand :: Prism' a (FilePath, [String]) _RawCommand = _CmdSpec . _RawCommand + {-# INLINE _RawCommandExe #-} _RawCommandExe :: Traversal' a FilePath _RawCommandExe = _RawCommand . _1 + {-# INLINE _RawCommandArgumentList #-} _RawCommandArgumentList :: Traversal' a [String] _RawCommandArgumentList = _RawCommand . _2 + {-# INLINE _RawCommandArguments #-} _RawCommandArguments :: Traversal' a String _RawCommandArguments = _RawCommandArgumentList . traverse +-- | +-- +-- >>> preview _ShellCommand (ShellCommand "ls -la") +-- Just "ls -la" +-- >>> preview _ShellCommand (RawCommand "ls" ["-la"]) +-- Nothing +-- >>> preview _RawCommand (RawCommand "ls" ["-la"]) +-- Just ("ls",["-la"]) +-- >>> preview _RawCommand (ShellCommand "ls -la") +-- Nothing +-- >>> review _ShellCommand "echo hello" :: CmdSpec +-- ShellCommand "echo hello" +-- >>> review _RawCommand ("/bin/ls", ["-la"]) :: CmdSpec +-- RawCommand "/bin/ls" ["-la"] instance AsCmdSpec CmdSpec where _CmdSpec = id _ShellCommand = prism' ShellCommand - (\case - ShellCommand a -> Just a - _ -> Nothing + ( \case + ShellCommand a -> Just a + _ -> Nothing ) _RawCommand = prism' (uncurry RawCommand) - (\case - RawCommand a b -> Just (a, b) - _ -> Nothing + ( \case + RawCommand a b -> Just (a, b) + _ -> Nothing ) - -class HasCmdSpec a where - cmdSpec :: - Lens' a CmdSpec - shellCommand :: - Traversal' a String - shellCommand = - cmdSpec . _ShellCommand - rawCommand :: - Traversal' a (FilePath, [String]) - rawCommand = - cmdSpec . _RawCommand - rawCommandExe :: - Traversal' a FilePath - rawCommandExe = - rawCommand . _1 - rawCommandArgumentList :: - Traversal' a [String] - rawCommandArgumentList = - rawCommand . _2 - rawCommandArguments :: - Traversal' a String - rawCommandArguments = - rawCommandArgumentList . traverse - -instance HasCmdSpec CmdSpec where - cmdSpec = - id - -instance HasCmdSpec CreateProcess where - cmdSpec f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\csc' -> CreateProcess csc' cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) (f csc) diff --git a/src/Control/Process/CreateProcess.hs b/src/Control/Process/CreateProcess.hs --- a/src/Control/Process/CreateProcess.hs +++ b/src/Control/Process/CreateProcess.hs @@ -1,37 +1,71 @@ -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.CreateProcess( - HasCreateProcess(..) -, AsCreateProcess(..) -, streams -, streams1 -) where +module Control.Process.CreateProcess + ( CreateProcess, + GetCreateProcess (..), + HasCreateProcess (..), + ReviewCreateProcess (..), + AsCreateProcess (..), + streams, + streams1, + ) +where -import Control.Applicative ( Applicative((<*>)) ) -import Control.Category ( Category(id, (.)) ) +import Control.Applicative (Applicative ((<*>))) +import Control.Category (id, (.)) import Control.Lens - ( Traversable(traverse), - _Just, - only, - Field1(_1), - Field2(_2), - Lens', - Prism', - Traversal', - Traversal1' ) -import Control.Process.UserID ( HasUserID(userIDWord32) ) -import Data.Bool ( Bool(True) ) -import Data.Functor ( Functor(fmap), (<$>) ) -import Data.Functor.Apply ( Apply((<.>)) ) -import Data.Maybe ( Maybe(..) ) -import Data.String ( String ) -import Data.Word ( Word32 ) -import System.FilePath ( FilePath ) -import System.Process(StdStream(..), CreateProcess(CreateProcess)) -import System.Process.Internals(GroupID, UserID) + ( Field1 (_1), + Field2 (_2), + Getter, + Lens', + Prism', + Review, + Traversable (traverse), + Traversal', + Traversal1', + only, + unto, + _Just, + ) +import Control.Process.UserID (HasUserID (userIDWord32)) +import Data.Bool (Bool (True)) +import Data.Functor (Functor (fmap), (<$>)) +import Data.Functor.Apply (Apply ((<.>))) +import Data.Maybe (Maybe (..)) +import Data.String (String) +import Data.Word (Word32) +import System.FilePath (FilePath) +import System.Process (CreateProcess, StdStream (..)) +import qualified System.Process as Process (CreateProcess (..)) +import System.Process.Internals (GroupID, UserID) -class HasCreateProcess a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens +-- >>> import System.Process (proc, shell) + +-- | Type class for values that can be viewed as a @CreateProcess@. +-- +-- >>> view getCreateProcess (proc "echo" ["hello"]) == proc "echo" ["hello"] +-- True +class GetCreateProcess a where + getCreateProcess :: + Getter a CreateProcess + +-- | +-- +-- >>> view getCreateProcess (proc "echo" ["hello"]) == proc "echo" ["hello"] +-- True +instance GetCreateProcess CreateProcess where + getCreateProcess = id + {-# INLINE getCreateProcess #-} + +-- | Type class for values with a lens into a @CreateProcess@. +-- +-- >>> view close_fds (proc "echo" ["hello"]) +-- False +class (GetCreateProcess a) => HasCreateProcess a where create_process :: Lens' a CreateProcess {-# INLINE child_group #-} @@ -105,113 +139,176 @@ use_process_jobs = create_process . use_process_jobs + {-# INLINE cwd' #-} cwd' :: Traversal' a FilePath cwd' = cwd . _Just + {-# INLINE envList #-} envList :: Traversal' a [(String, String)] envList = env . _Just + {-# INLINE envElement #-} envElement :: Traversal' a (String, String) envElement = envList . traverse + {-# INLINE envElementKey #-} envElementKey :: Traversal' a String envElementKey = envElement . _1 + {-# INLINE envElementValue #-} envElementValue :: Traversal' a String envElementValue = envElement . _2 + {-# INLINE close_fds' #-} close_fds' :: Traversal' a () close_fds' = close_fds . only True + {-# INLINE create_group' #-} create_group' :: Traversal' a () create_group' = create_group . only True + {-# INLINE delegate_ctlc' #-} delegate_ctlc' :: Traversal' a () delegate_ctlc' = delegate_ctlc . only True + {-# INLINE detach_console' #-} detach_console' :: Traversal' a () detach_console' = detach_console . only True + {-# INLINE create_new_console' #-} create_new_console' :: Traversal' a () create_new_console' = create_new_console . only True + {-# INLINE new_session' #-} new_session' :: Traversal' a () new_session' = new_session . only True + {-# INLINE child_group' #-} child_group' :: Traversal' a GroupID child_group' = child_group . _Just + {-# INLINE child_user' #-} child_user' :: Traversal' a UserID child_user' = child_user . _Just + {-# INLINE child_user'' #-} child_user'' :: Traversal' a Word32 child_user'' = child_user' . userIDWord32 + {-# INLINE use_process_jobs' #-} use_process_jobs' :: Traversal' a () use_process_jobs' = use_process_jobs . only True +-- | +-- +-- >>> view close_fds (proc "echo" ["hello"]) +-- False +-- >>> view (std_in) (proc "echo" ["hello"]) +-- Inherit +-- >>> view cwd (proc "echo" ["hello"]) +-- Nothing instance HasCreateProcess CreateProcess where create_process = id - child_group f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\chg' -> CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg' chu upj) (f chg) - child_user f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\chu' -> CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu' upj) (f chu) - close_fds f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\clf' -> CreateProcess csc cw en sti sto ste clf' crg dct dcl cnc nss chg chu upj) (f clf) - create_group f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\crg' -> CreateProcess csc cw en sti sto ste clf crg' dct dcl cnc nss chg chu upj) (f crg) - create_new_console f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\cnc' -> CreateProcess csc cw en sti sto ste clf crg dct dcl cnc' nss chg chu upj) (f cnc) - cwd f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\cw' -> CreateProcess csc cw' en sti sto ste clf crg dct dcl cnc nss chg chu upj) (f cw) - delegate_ctlc f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\dct' -> CreateProcess csc cw en sti sto ste clf crg dct' dcl cnc nss chg chu upj) (f dct) - detach_console f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\dcl' -> CreateProcess csc cw en sti sto ste clf crg dct dcl' cnc nss chg chu upj) (f dcl) - env f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\en' -> CreateProcess csc cw en' sti sto ste clf crg dct dcl cnc nss chg chu upj) (f en) - new_session f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\nss' -> CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss' chg chu upj) (f nss) - std_err f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\ste' -> CreateProcess csc cw en sti sto ste' clf crg dct dcl cnc nss chg chu upj) (f ste) - std_in f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\sti' -> CreateProcess csc cw en sti' sto ste clf crg dct dcl cnc nss chg chu upj) (f sti) - std_out f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (\sto' -> CreateProcess csc cw en sti sto' ste clf crg dct dcl cnc nss chg chu upj) (f sto) - use_process_jobs f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - fmap (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu) (f upj) + child_group f p = + fmap (\x -> p {Process.child_group = x}) (f (Process.child_group p)) + child_user f p = + fmap (\x -> p {Process.child_user = x}) (f (Process.child_user p)) + close_fds f p = + fmap (\x -> p {Process.close_fds = x}) (f (Process.close_fds p)) + create_group f p = + fmap (\x -> p {Process.create_group = x}) (f (Process.create_group p)) + create_new_console f p = + fmap (\x -> p {Process.create_new_console = x}) (f (Process.create_new_console p)) + cwd f p = + fmap (\x -> p {Process.cwd = x}) (f (Process.cwd p)) + delegate_ctlc f p = + fmap (\x -> p {Process.delegate_ctlc = x}) (f (Process.delegate_ctlc p)) + detach_console f p = + fmap (\x -> p {Process.detach_console = x}) (f (Process.detach_console p)) + env f p = + fmap (\x -> p {Process.env = x}) (f (Process.env p)) + new_session f p = + fmap (\x -> p {Process.new_session = x}) (f (Process.new_session p)) + std_err f p = + fmap (\x -> p {Process.std_err = x}) (f (Process.std_err p)) + std_in f p = + fmap (\x -> p {Process.std_in = x}) (f (Process.std_in p)) + std_out f p = + fmap (\x -> p {Process.std_out = x}) (f (Process.std_out p)) + use_process_jobs f p = + fmap (\x -> p {Process.use_process_jobs = x}) (f (Process.use_process_jobs p)) -class AsCreateProcess a where +-- | Type class for values that can be constructed from a @CreateProcess@. +-- +-- >>> review reviewCreateProcess (proc "echo" ["hi"]) == proc "echo" ["hi"] +-- True +class ReviewCreateProcess a where + reviewCreateProcess :: + Review a CreateProcess + +-- | +-- +-- >>> review reviewCreateProcess (proc "echo" ["hi"]) == proc "echo" ["hi"] +-- True +instance ReviewCreateProcess CreateProcess where + reviewCreateProcess = unto id + {-# INLINE reviewCreateProcess #-} + +-- | Type class for values with a prism into a @CreateProcess@. +-- +-- >>> preview _CreateProcess (proc "echo" ["hi"]) == Just (proc "echo" ["hi"]) +-- True +class (ReviewCreateProcess a) => AsCreateProcess a where _CreateProcess :: Prism' a CreateProcess +-- | +-- +-- >>> preview _CreateProcess (proc "echo" ["hi"]) == Just (proc "echo" ["hi"]) +-- True instance AsCreateProcess CreateProcess where _CreateProcess = id +-- | +-- +-- >>> toListOf streams (proc "echo" ["hi"]) +-- [Inherit,Inherit,Inherit] +-- >>> set streams CreatePipe (proc "echo" ["hi"]) ^. std_in +-- CreatePipe streams :: Traversal' CreateProcess StdStream -streams f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - (\sti' sto' ste' -> CreateProcess csc cw en sti' sto' ste' clf crg dct dcl cnc nss chg chu upj) <$> f sti <*> f sto <*> f ste +streams f p = + (\sti' sto' ste' -> p {Process.std_in = sti', Process.std_out = sto', Process.std_err = ste'}) + <$> f (Process.std_in p) + <*> f (Process.std_out p) + <*> f (Process.std_err p) +-- | +-- +-- >>> toListOf streams1 (proc "echo" ["hi"]) +-- [Inherit,Inherit,Inherit] streams1 :: Traversal1' CreateProcess StdStream -streams1 f (CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj) = - (\sti' sto' ste' -> CreateProcess csc cw en sti' sto' ste' clf crg dct dcl cnc nss chg chu upj) <$> f sti <.> f sto <.> f ste +streams1 f p = + (\sti' sto' ste' -> p {Process.std_in = sti', Process.std_out = sto', Process.std_err = ste'}) + <$> f (Process.std_in p) + <.> f (Process.std_out p) + <.> f (Process.std_err p) diff --git a/src/Control/Process/FD.hs b/src/Control/Process/FD.hs --- a/src/Control/Process/FD.hs +++ b/src/Control/Process/FD.hs @@ -1,44 +1,130 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.FD( - HasFD(..) -, AsFD(..) -) where +module Control.Process.FD + ( FD, + GetFD (..), + HasFD (..), + ReviewFD (..), + AsFD (..), + ) +where -import Control.Category((.), id) -import Control.Lens ( iso, Lens', Prism' ) -import Data.Int ( Int32 ) -import Foreign.C.Types ( CInt(CInt) ) -import System.Posix.Internals ( FD ) +import Control.Category (id, (.)) +import Control.Lens (Getter, Lens', Prism', Review, iso, unto) +import Data.Int (Int32) +import Foreign.C.Types (CInt (CInt)) +import System.Posix.Internals (FD) -class HasFD a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens + +-- | Type class for values that can be viewed as an @FD@. +-- +-- >>> view getFD (3 :: FD) +-- 3 +class GetFD a where + getFD :: + Getter a FD + {-# INLINE getFDInt32 #-} + getFDInt32 :: + Getter a Int32 + getFDInt32 = + getFD + . iso + (\(CInt x) -> x) + CInt + +-- | +-- +-- >>> view getFD (3 :: FD) +-- 3 +-- >>> view getFDInt32 (3 :: FD) +-- 3 +instance GetFD FD where + getFD = id + {-# INLINE getFD #-} + +-- | Type class for values with a lens into an @FD@. +-- +-- >>> view fd (3 :: FD) +-- 3 +class (GetFD a) => HasFD a where fd :: Lens' a FD + {-# INLINE fdInt32 #-} fdInt32 :: Lens' a Int32 fdInt32 = - fd . - iso + fd + . iso (\(CInt x) -> x) CInt +-- | +-- +-- >>> view fd (3 :: FD) +-- 3 +-- >>> view fdInt32 (3 :: FD) +-- 3 +-- >>> set fdInt32 7 (3 :: FD) +-- 7 instance HasFD FD where fd = id -class AsFD a where +-- | Type class for values that can be constructed from an @FD@. +-- +-- >>> review reviewFD (3 :: FD) :: FD +-- 3 +class ReviewFD a where + reviewFD :: + Review a FD + {-# INLINE reviewFDInt32 #-} + reviewFDInt32 :: + Review a Int32 + reviewFDInt32 = + reviewFD + . iso + (\(CInt x) -> x) + CInt + +-- | +-- +-- >>> review reviewFD (3 :: FD) :: FD +-- 3 +-- >>> review reviewFDInt32 7 :: FD +-- 7 +instance ReviewFD FD where + reviewFD = unto id + {-# INLINE reviewFD #-} + +-- | Type class for values with a prism into an @FD@. +-- +-- >>> preview _FD (3 :: FD) +-- Just 3 +class (ReviewFD a) => AsFD a where _FD :: Prism' a FD + {-# INLINE _FDInt32 #-} _FDInt32 :: Prism' a Int32 _FDInt32 = - _FD . - iso + _FD + . iso (\(CInt x) -> x) CInt +-- | +-- +-- >>> preview _FD (3 :: FD) +-- Just 3 +-- >>> preview _FDInt32 (3 :: FD) +-- Just 3 +-- >>> review _FDInt32 7 :: FD +-- 7 instance AsFD FD where _FD = id diff --git a/src/Control/Process/GroupID.hs b/src/Control/Process/GroupID.hs --- a/src/Control/Process/GroupID.hs +++ b/src/Control/Process/GroupID.hs @@ -1,28 +1,88 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.GroupID( - HasGroupID(..) -, AsGroupID(..) -) where +module Control.Process.GroupID + ( GroupID, + GetGroupID (..), + HasGroupID (..), + ReviewGroupID (..), + AsGroupID (..), + ) +where -import Control.Category(id) -import Control.Lens ( Lens', Prism' ) -import System.Process.Internals ( GroupID ) +import Control.Category (id) +import Control.Lens (Getter, Lens', Prism', Review, unto) +import System.Process.Internals (GroupID) -class HasGroupID a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens + +-- | Type class for values that can be viewed as a @GroupID@. +-- +-- >>> view getGroupID (42 :: GroupID) +-- 42 +class GetGroupID a where + getGroupID :: + Getter a GroupID + +-- | +-- +-- >>> view getGroupID (42 :: GroupID) +-- 42 +instance GetGroupID GroupID where + getGroupID = id + {-# INLINE getGroupID #-} + +-- | Type class for values with a lens into a @GroupID@. +-- +-- >>> view groupID (42 :: GroupID) +-- 42 +class (GetGroupID a) => HasGroupID a where groupID :: Lens' a GroupID +-- | +-- +-- >>> view groupID (42 :: GroupID) +-- 42 +-- >>> set groupID 99 (42 :: GroupID) +-- 99 instance HasGroupID GroupID where groupID = id -class AsGroupID a where +-- | Type class for values that can be constructed from a @GroupID@. +-- +-- >>> review reviewGroupID (42 :: GroupID) :: GroupID +-- 42 +class ReviewGroupID a where + reviewGroupID :: + Review a GroupID + +-- | +-- +-- >>> review reviewGroupID (42 :: GroupID) :: GroupID +-- 42 +instance ReviewGroupID GroupID where + reviewGroupID = unto id + {-# INLINE reviewGroupID #-} + +-- | Type class for values with a prism into a @GroupID@. +-- +-- >>> preview _GroupID (42 :: GroupID) +-- Just 42 +class (ReviewGroupID a) => AsGroupID a where _GroupID :: Prism' a GroupID +-- | +-- +-- >>> preview _GroupID (42 :: GroupID) +-- Just 42 +-- >>> review _GroupID 42 :: GroupID +-- 42 instance AsGroupID GroupID where _GroupID = id diff --git a/src/Control/Process/Handle.hs b/src/Control/Process/Handle.hs --- a/src/Control/Process/Handle.hs +++ b/src/Control/Process/Handle.hs @@ -1,39 +1,113 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.Handle( - HasHandle(..) -, AsHandle(..) -) where +module Control.Process.Handle + ( Handle, + GetHandle (..), + HasHandle (..), + ReviewHandle (..), + AsHandle (..), + ) +where -import Control.Category(id) -import Control.Lens ( prism', Lens', Prism' ) -import Data.Maybe ( Maybe(Nothing, Just) ) -import System.IO ( Handle ) -import System.Process ( StdStream(UseHandle) ) +import Control.Category (id) +import Control.Lens (Getter, Lens', Prism', Review, prism', unto) +import Data.Maybe (Maybe (Just, Nothing)) +import System.IO (Handle) +import System.Process (StdStream (UseHandle)) -class HasHandle a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens +-- >>> import System.IO (stdin, stdout) +-- >>> import System.Process (StdStream(..)) + +-- | Type class for values that can be viewed as a @Handle@. +-- +-- >>> view getHandle stdin +-- {handle: } +class GetHandle a where + getHandle :: + Getter a Handle + +-- | +-- +-- >>> view getHandle stdin +-- {handle: } +instance GetHandle Handle where + getHandle = id + {-# INLINE getHandle #-} + +-- | Type class for values with a lens into a @Handle@. +-- +-- >>> view handle stdin +-- {handle: } +class (GetHandle a) => HasHandle a where handle :: Lens' a Handle +-- | +-- +-- >>> view handle stdin +-- {handle: } instance HasHandle Handle where handle = id -class AsHandle a where +-- | Type class for values that can be constructed from a @Handle@. +-- +-- >>> review reviewHandle stdin :: Handle +-- {handle: } +class ReviewHandle a where + reviewHandle :: + Review a Handle + +-- | +-- +-- >>> review reviewHandle stdin :: Handle +-- {handle: } +instance ReviewHandle Handle where + reviewHandle = unto id + {-# INLINE reviewHandle #-} + +-- | +-- +-- >>> review reviewHandle stdout :: StdStream +-- UseHandle {handle: } +instance ReviewHandle StdStream where + reviewHandle = unto UseHandle + {-# INLINE reviewHandle #-} + +-- | Type class for values with a prism into a @Handle@. +-- +-- >>> preview _Handle stdin +-- Just {handle: } +class (ReviewHandle a) => AsHandle a where _Handle :: Prism' a Handle +-- | +-- +-- >>> preview _Handle stdin +-- Just {handle: } instance AsHandle Handle where _Handle = id +-- | +-- +-- >>> preview _Handle (UseHandle stdout) +-- Just {handle: } +-- >>> preview _Handle (Inherit :: StdStream) +-- Nothing +-- >>> review _Handle stdout :: StdStream +-- UseHandle {handle: } instance AsHandle StdStream where _Handle = prism' UseHandle - (\case - UseHandle a -> Just a - _ -> Nothing + ( \case + UseHandle a -> Just a + _ -> Nothing ) diff --git a/src/Control/Process/Pid.hs b/src/Control/Process/Pid.hs --- a/src/Control/Process/Pid.hs +++ b/src/Control/Process/Pid.hs @@ -1,44 +1,130 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.Pid( - HasPid(..) -, AsPid(..) -) where +module Control.Process.Pid + ( Pid, + GetPid (..), + HasPid (..), + ReviewPid (..), + AsPid (..), + ) +where -import Control.Category((.), id) -import Control.Lens ( iso, Lens', Prism' ) -import Data.Int ( Int32 ) -import System.Posix.Types ( CPid(CPid) ) -import System.Process ( Pid ) +import Control.Category (id, (.)) +import Control.Lens (Getter, Lens', Prism', Review, iso, unto) +import Data.Int (Int32) +import System.Posix.Types (CPid (CPid)) +import System.Process (Pid) -class HasPid a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens + +-- | Type class for values that can be viewed as a @Pid@. +-- +-- >>> view viewPid (CPid 42) +-- 42 +class GetPid a where + viewPid :: + Getter a Pid + {-# INLINE viewPidInt32 #-} + viewPidInt32 :: + Getter a Int32 + viewPidInt32 = + viewPid + . iso + (\(CPid x) -> x) + CPid + +-- | +-- +-- >>> view viewPid (CPid 42) +-- 42 +-- >>> view viewPidInt32 (CPid 42) +-- 42 +instance GetPid Pid where + viewPid = id + {-# INLINE viewPid #-} + +-- | Type class for values with a lens into a @Pid@. +-- +-- >>> view pid (CPid 42) +-- 42 +class (GetPid a) => HasPid a where pid :: Lens' a Pid + {-# INLINE pidInt32 #-} pidInt32 :: Lens' a Int32 pidInt32 = - pid . - iso + pid + . iso (\(CPid x) -> x) CPid +-- | +-- +-- >>> view pid (CPid 42) +-- 42 +-- >>> view pidInt32 (CPid 42) +-- 42 +-- >>> set pidInt32 99 (CPid 42) +-- 99 instance HasPid Pid where pid = id -class AsPid a where +-- | Type class for values that can be constructed from a @Pid@. +-- +-- >>> review reviewPid (CPid 42) :: Pid +-- 42 +class ReviewPid a where + reviewPid :: + Review a Pid + {-# INLINE reviewPidInt32 #-} + reviewPidInt32 :: + Review a Int32 + reviewPidInt32 = + reviewPid + . iso + (\(CPid x) -> x) + CPid + +-- | +-- +-- >>> review reviewPid (CPid 42) :: Pid +-- 42 +-- >>> review reviewPidInt32 99 :: Pid +-- 99 +instance ReviewPid Pid where + reviewPid = unto id + {-# INLINE reviewPid #-} + +-- | Type class for values with a prism into a @Pid@. +-- +-- >>> preview _Pid (CPid 42) +-- Just 42 +class (ReviewPid a) => AsPid a where _Pid :: Prism' a Pid + {-# INLINE _PidInt32 #-} _PidInt32 :: Prism' a Int32 _PidInt32 = - _Pid . - iso + _Pid + . iso (\(CPid x) -> x) CPid +-- | +-- +-- >>> preview _Pid (CPid 42) +-- Just 42 +-- >>> preview _PidInt32 (CPid 42) +-- Just 42 +-- >>> review _PidInt32 99 :: Pid +-- 99 instance AsPid Pid where _Pid = id diff --git a/src/Control/Process/Process.hs b/src/Control/Process/Process.hs --- a/src/Control/Process/Process.hs +++ b/src/Control/Process/Process.hs @@ -1,143 +1,155 @@ -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.Process( - module Process -, readCreateProcessWithExitCode -, readProcessWithExitCode -, waitForProcess -, getProcessExitCode -, getProcessExitCodeBool -) where +module Control.Process.Process + ( module Process, + readCreateProcessWithExitCode, + readProcessWithExitCode, + waitForProcess, + getProcessExitCode, + getProcessExitCodeBool, + getPid, + ) +where -import Control.Applicative ( Applicative(pure) ) -import Control.Category ( Category((.)) ) -import Control.Exception ( Exception ) +import Control.Applicative (Applicative (pure)) +import Control.Category (Category ((.))) +import Control.Exception (Exception) import Control.Exitcode - ( ExitcodeT, - fromExitCode', - liftExitcode, - hoistExitcode, - tryExitcode, - _Exitcode1, - liftTryExitcode ) -import Control.Lens ( Identity(runIdentity), set ) -import Control.Monad ( Monad((>>=)) ) -import Control.Monad.Except ( ExceptT(..) ) -import Data.Bifunctor ( Bifunctor(bimap) ) -import Data.Bool ( Bool ) -import Data.Maybe ( Maybe(..), isJust, maybe ) -import Data.String ( String ) -import System.FilePath( FilePath ) -import System.IO ( IO ) -import System.Process as Process( - createProcess - , createProcess_ - , shell - , proc - , CreateProcess() - , CmdSpec(..) - , StdStream(..) - , ProcessHandle - , callProcess - , callCommand - , spawnProcess - , readCreateProcess - , readProcess - , withCreateProcess - , cleanupProcess - , showCommandForUser - , Pid - , getPid - , getCurrentPid - , terminateProcess - , interruptProcessGroupOf - , createPipe - , createPipeFd + ( Exitcode, + bimapExitcode, + fromExitCode', + hoistExitcode, + liftTryExitcode, + mkExitSuccess, + tryExitcode, ) -import qualified System.Process as P(readCreateProcessWithExitCode, readProcessWithExitCode, waitForProcess, getProcessExitCode) +import Control.Monad (Monad ((>>=))) +import Control.Monad.Except (ExceptT (..)) +import Data.Bool (Bool) +import Data.Function (const) +import Data.Functor.Identity (runIdentity) +import Data.Maybe (Maybe (..), isJust, maybe) +import Data.String (String) +import System.FilePath (FilePath) +import System.IO (IO) +import System.Process as Process + ( CmdSpec (..), + CreateProcess (), + Pid, + ProcessHandle, + StdStream (..), + callCommand, + callProcess, + cleanupProcess, + createPipe, + createPipeFd, + createProcess, + createProcess_, + getCurrentPid, + interruptProcessGroupOf, + proc, + readCreateProcess, + readProcess, + shell, + showCommandForUser, + spawnProcess, + terminateProcess, + withCreateProcess, + ) +import qualified System.Process as P (getProcessExitCode, getPid, readCreateProcessWithExitCode, readProcessWithExitCode, waitForProcess) +getPid :: ProcessHandle -> IO (Maybe Pid) +getPid = P.getPid + -- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it -- lets you pass 'CreateProcess' giving better flexibility. -- -- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess -- record will be ignored. +{-# INLINE readCreateProcessWithExitCode #-} readCreateProcessWithExitCode :: - Exception e' => - CreateProcess - -> String -- ^ standard input - -> ExitcodeT (ExceptT e' IO) (String, String) (String, String) -- ^ exitcode, stdout, stderr + (Exception e') => + CreateProcess -> + -- | standard input + String -> + -- | exitcode, stdout, stderr + Exitcode (String, String) (ExceptT e' IO) (String, String) readCreateProcessWithExitCode p a = - tryExitcode (liftExitcode (P.readCreateProcessWithExitCode p a)) >>= \(x, y, z) -> - hoistExitcode (pure . runIdentity) (set _Exitcode1 (y, z) (fromExitCode' x)) + tryExitcode (mkExitSuccess (P.readCreateProcessWithExitCode p a)) >>= \(x, y, z) -> + hoistExitcode (pure . runIdentity) (bimapExitcode (const (y, z)) (const (y, z)) (fromExitCode' x)) +{-# INLINE readProcessWithExitCode #-} readProcessWithExitCode :: - Exception e' => - FilePath -- ^ Filename of the executable (see 'RawCommand' for details) - -> [String] -- ^ any arguments - -> String -- ^ standard input - -> ExitcodeT (ExceptT e' IO) (String, String) (String, String) -- ^ exitcode, stdout, stderr + (Exception e') => + -- | Filename of the executable (see 'RawCommand' for details) + FilePath -> + -- | any arguments + [String] -> + -- | standard input + String -> + -- | exitcode, stdout, stderr + Exitcode (String, String) (ExceptT e' IO) (String, String) readProcessWithExitCode p a i = - tryExitcode (liftExitcode (P.readProcessWithExitCode p a i)) >>= \(x, y, z) -> - hoistExitcode (pure . runIdentity) (set _Exitcode1 (y, z) (fromExitCode' x)) - -{- | Waits for the specified process to terminate, and returns its exit code. -On Unix systems, may throw 'UserInterrupt' when using 'delegate_ctlc'. - -GHC Note: in order to call @waitForProcess@ without blocking all the -other threads in the system, you must compile the program with -@-threaded@. - -Note that it is safe to call @waitForProcess@ for the same process in multiple -threads. When the process ends, threads blocking on this call will wake in -FIFO order. When using 'delegate_ctlc' and the process is interrupted, only -the first waiting thread will throw 'UserInterrupt'. - -(/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@ -indicates that the child was terminated by signal @/signum/@. -The signal numbers are platform-specific, so to test for a specific signal use -the constants provided by "System.Posix.Signals" in the @unix@ package. -Note: core dumps are not reported, use "System.Posix.Process" if you need this -detail. + tryExitcode (mkExitSuccess (P.readProcessWithExitCode p a i)) >>= \(x, y, z) -> + hoistExitcode (pure . runIdentity) (bimapExitcode (const (y, z)) (const (y, z)) (fromExitCode' x)) --} +-- | Waits for the specified process to terminate, and returns its exit code. +-- On Unix systems, may throw 'UserInterrupt' when using 'delegate_ctlc'. +-- +-- GHC Note: in order to call @waitForProcess@ without blocking all the +-- other threads in the system, you must compile the program with +-- @-threaded@. +-- +-- Note that it is safe to call @waitForProcess@ for the same process in multiple +-- threads. When the process ends, threads blocking on this call will wake in +-- FIFO order. When using 'delegate_ctlc' and the process is interrupted, only +-- the first waiting thread will throw 'UserInterrupt'. +-- +-- (/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@ +-- indicates that the child was terminated by signal @/signum/@. +-- The signal numbers are platform-specific, so to test for a specific signal use +-- the constants provided by "System.Posix.Signals" in the @unix@ package. +-- Note: core dumps are not reported, use "System.Posix.Process" if you need this +-- detail. +{-# INLINE waitForProcess #-} waitForProcess :: - Exception e' => - ProcessHandle - -> ExitcodeT (ExceptT e' IO) () () + (Exception e') => + ProcessHandle -> + Exitcode () (ExceptT e' IO) () waitForProcess h = - tryExitcode (liftExitcode (P.waitForProcess h)) >>= \x -> + tryExitcode (mkExitSuccess (P.waitForProcess h)) >>= \x -> hoistExitcode (pure . runIdentity) (fromExitCode' x) -{- | -This is a non-blocking version of 'waitForProcess'. If the process is -still running, 'Nothing' is returned. If the process has exited, then -@'Just' e@ is returned where @e@ is the exit code of the process. - -On Unix systems, see 'waitForProcess' for the meaning of exit codes -when the process died as the result of a signal. May throw -'UserInterrupt' when using 'delegate_ctlc'. --} +-- | +-- This is a non-blocking version of 'waitForProcess'. If the process is +-- still running, 'Nothing' is returned. If the process has exited, then +-- @'Just' e@ is returned where @e@ is the exit code of the process. +-- +-- On Unix systems, see 'waitForProcess' for the meaning of exit codes +-- when the process died as the result of a signal. May throw +-- 'UserInterrupt' when using 'delegate_ctlc'. +{-# INLINE getProcessExitCode #-} getProcessExitCode :: - Exception e' => - ProcessHandle - -> ExitcodeT (ExceptT e' IO) (Maybe ()) (Maybe ()) + (Exception e') => + ProcessHandle -> + Exitcode (Maybe ()) (ExceptT e' IO) (Maybe ()) getProcessExitCode h = - liftTryExitcode (P.getProcessExitCode h) >>= - maybe (pure Nothing) (hoistExitcode (pure . runIdentity) . set _Exitcode1 (Just ()) . fromExitCode') - -{- | -This is a non-blocking version of 'waitForProcess'. If the process is -still running, 'Nothing' is returned. If the process has exited, then -@'Just' e@ is returned where @e@ is the exit code of the process. + liftTryExitcode (P.getProcessExitCode h) + >>= maybe (pure Nothing) (hoistExitcode (pure . runIdentity) . bimapExitcode (const (Just ())) (const (Just ())) . fromExitCode') -On Unix systems, see 'waitForProcess' for the meaning of exit codes -when the process died as the result of a signal. May throw -'UserInterrupt' when using 'delegate_ctlc'. --} +-- | +-- This is a non-blocking version of 'waitForProcess'. If the process is +-- still running, 'Nothing' is returned. If the process has exited, then +-- @'Just' e@ is returned where @e@ is the exit code of the process. +-- +-- On Unix systems, see 'waitForProcess' for the meaning of exit codes +-- when the process died as the result of a signal. May throw +-- 'UserInterrupt' when using 'delegate_ctlc'. +{-# INLINE getProcessExitCodeBool #-} getProcessExitCodeBool :: - Exception e' => - ProcessHandle - -> ExitcodeT (ExceptT e' IO) Bool Bool -getProcessExitCodeBool = - bimap isJust isJust . getProcessExitCode + (Exception e') => + ProcessHandle -> + Exitcode Bool (ExceptT e' IO) Bool +getProcessExitCodeBool h = + bimapExitcode isJust isJust (getProcessExitCode h) diff --git a/src/Control/Process/ProcessHandle.hs b/src/Control/Process/ProcessHandle.hs --- a/src/Control/Process/ProcessHandle.hs +++ b/src/Control/Process/ProcessHandle.hs @@ -1,16 +1,30 @@ -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.ProcessHandle( - HasProcessHandle(..) -, AsProcessHandle(..) -) where +module Control.Process.ProcessHandle + ( ProcessHandle, + GetProcessHandle (..), + HasProcessHandle (..), + ReviewProcessHandle (..), + AsProcessHandle (..), + ) +where -import Control.Category(id) -import System.Process ( ProcessHandle ) -import Control.Lens ( Lens', Prism' ) +import Control.Category (id) +import Control.Lens (Getter, Lens', Prism', Review, unto) +import System.Process (ProcessHandle) -class HasProcessHandle a where +-- | Type class for values that can be viewed as a @ProcessHandle@. +class GetProcessHandle a where + getProcessHandle :: + Getter a ProcessHandle + +instance GetProcessHandle ProcessHandle where + getProcessHandle = id + {-# INLINE getProcessHandle #-} + +-- | Type class for values with a lens into a @ProcessHandle@. +class (GetProcessHandle a) => HasProcessHandle a where processHandle :: Lens' a ProcessHandle @@ -18,7 +32,17 @@ processHandle = id -class AsProcessHandle a where +-- | Type class for values that can be constructed from a @ProcessHandle@. +class ReviewProcessHandle a where + reviewProcessHandle :: + Review a ProcessHandle + +instance ReviewProcessHandle ProcessHandle where + reviewProcessHandle = unto id + {-# INLINE reviewProcessHandle #-} + +-- | Type class for values with a prism into a @ProcessHandle@. +class (ReviewProcessHandle a) => AsProcessHandle a where _ProcessHandle :: Prism' a ProcessHandle diff --git a/src/Control/Process/StdStream.hs b/src/Control/Process/StdStream.hs --- a/src/Control/Process/StdStream.hs +++ b/src/Control/Process/StdStream.hs @@ -1,63 +1,155 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.StdStream( - StdStream(..) -, AsStdStream(..) -, HasStdStream(..) -) where +module Control.Process.StdStream + ( StdStream (..), + GetStdStream (..), + HasStdStream (..), + ReviewStdStream (..), + AsStdStream (..), + ) +where -import Control.Category ( Category(id, (.)) ) -import Control.Lens ( prism', Lens', Prism' ) -import Data.Maybe ( Maybe(Nothing, Just) ) -import System.Process ( StdStream(..) ) +import Control.Category (id, (.)) +import Control.Lens (Getter, Lens', Prism', Review, prism', unto) +import Data.Maybe (Maybe (Just, Nothing)) +import System.IO (Handle) +import System.Process (StdStream (..)) -class AsStdStream a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens +-- >>> import System.IO (stdin, stdout) + +-- | Type class for values that can be viewed as a @StdStream@. +-- +-- >>> view getStdStream Inherit +-- Inherit +class GetStdStream a where + getStdStream :: + Getter a StdStream + +-- | +-- +-- >>> view getStdStream Inherit +-- Inherit +instance GetStdStream StdStream where + getStdStream = id + {-# INLINE getStdStream #-} + +-- | Type class for values with a lens into a @StdStream@. +-- +-- >>> view stdStream Inherit +-- Inherit +class (GetStdStream a) => HasStdStream a where + stdStream :: + Lens' a StdStream + +-- | +-- +-- >>> view stdStream Inherit +-- Inherit +-- >>> set stdStream CreatePipe Inherit +-- CreatePipe +instance HasStdStream StdStream where + stdStream = + id + +-- | Type class for values that can be constructed from a @StdStream@. +-- +-- >>> review reviewStdStream Inherit :: StdStream +-- Inherit +class ReviewStdStream a where + reviewStdStream :: + Review a StdStream + +-- | +-- +-- >>> review reviewStdStream Inherit :: StdStream +-- Inherit +instance ReviewStdStream StdStream where + reviewStdStream = unto id + {-# INLINE reviewStdStream #-} + +-- | Type class for values with a prism into a @StdStream@. +-- +-- >>> preview _StdStream Inherit +-- Just Inherit +class (ReviewStdStream a) => AsStdStream a where _StdStream :: Prism' a StdStream + {-# INLINE _Inherit #-} _Inherit :: Prism' a () _Inherit = _StdStream . _Inherit + {-# INLINE _CreatePipe #-} _CreatePipe :: Prism' a () _CreatePipe = _StdStream . _CreatePipe + {-# INLINE _UseHandle #-} + _UseHandle :: + Prism' a Handle + _UseHandle = + _StdStream . _UseHandle + {-# INLINE _NoStream #-} _NoStream :: Prism' a () _NoStream = _StdStream . _NoStream +-- | +-- +-- >>> preview _Inherit Inherit +-- Just () +-- >>> preview _Inherit CreatePipe +-- Nothing +-- >>> preview _CreatePipe CreatePipe +-- Just () +-- >>> preview _UseHandle (UseHandle stdout) +-- Just {handle: } +-- >>> preview _UseHandle Inherit +-- Nothing +-- >>> preview _NoStream NoStream +-- Just () +-- >>> review _Inherit () :: StdStream +-- Inherit +-- >>> review _CreatePipe () :: StdStream +-- CreatePipe +-- >>> review _UseHandle stdout :: StdStream +-- UseHandle {handle: } +-- >>> review _NoStream () :: StdStream +-- NoStream instance AsStdStream StdStream where _StdStream = id _Inherit = prism' (\() -> Inherit) - (\case - Inherit -> Just () - _ -> Nothing + ( \case + Inherit -> Just () + _ -> Nothing ) _CreatePipe = prism' (\() -> CreatePipe) - (\case - CreatePipe -> Just () - _ -> Nothing + ( \case + CreatePipe -> Just () + _ -> Nothing ) + _UseHandle = + prism' + UseHandle + ( \case + UseHandle a -> Just a + _ -> Nothing + ) _NoStream = prism' (\() -> NoStream) - (\case - NoStream -> Just () - _ -> Nothing + ( \case + NoStream -> Just () + _ -> Nothing ) - -class HasStdStream a where - stdStream :: - Lens' a StdStream - -instance HasStdStream StdStream where - stdStream = - id diff --git a/src/Control/Process/UserID.hs b/src/Control/Process/UserID.hs --- a/src/Control/Process/UserID.hs +++ b/src/Control/Process/UserID.hs @@ -1,44 +1,130 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Control.Process.UserID( - HasUserID(..) -, AsUserID(..) -) where +module Control.Process.UserID + ( UserID, + GetUserID (..), + HasUserID (..), + ReviewUserID (..), + AsUserID (..), + ) +where -import Control.Category((.), id) -import Control.Lens ( iso, Lens', Prism' ) -import Data.Word ( Word32 ) -import System.Posix.Types ( CUid(CUid) ) -import System.Process.Internals ( UserID ) +import Control.Category (id, (.)) +import Control.Lens (Getter, Lens', Prism', Review, iso, unto) +import Data.Word (Word32) +import System.Posix.Types (CUid (CUid)) +import System.Process.Internals (UserID) -class HasUserID a where +-- $setup +-- >>> import Prelude +-- >>> import Control.Lens + +-- | Type class for values that can be viewed as a @UserID@. +-- +-- >>> view getUserID (CUid 1000) +-- 1000 +class GetUserID a where + getUserID :: + Getter a UserID + {-# INLINE getUserIDWord32 #-} + getUserIDWord32 :: + Getter a Word32 + getUserIDWord32 = + getUserID + . iso + (\(CUid x) -> x) + CUid + +-- | +-- +-- >>> view getUserID (CUid 1000) +-- 1000 +-- >>> view getUserIDWord32 (CUid 1000) +-- 1000 +instance GetUserID UserID where + getUserID = id + {-# INLINE getUserID #-} + +-- | Type class for values with a lens into a @UserID@. +-- +-- >>> view userID (CUid 1000) +-- 1000 +class (GetUserID a) => HasUserID a where userID :: Lens' a UserID + {-# INLINE userIDWord32 #-} userIDWord32 :: Lens' a Word32 userIDWord32 = - userID . - iso + userID + . iso (\(CUid x) -> x) CUid +-- | +-- +-- >>> view userID (CUid 1000) +-- 1000 +-- >>> view userIDWord32 (CUid 1000) +-- 1000 +-- >>> set userIDWord32 0 (CUid 1000) +-- 0 instance HasUserID UserID where userID = id -class AsUserID a where +-- | Type class for values that can be constructed from a @UserID@. +-- +-- >>> review reviewUserID (CUid 1000) :: UserID +-- 1000 +class ReviewUserID a where + reviewUserID :: + Review a UserID + {-# INLINE reviewUserIDWord32 #-} + reviewUserIDWord32 :: + Review a Word32 + reviewUserIDWord32 = + reviewUserID + . iso + (\(CUid x) -> x) + CUid + +-- | +-- +-- >>> review reviewUserID (CUid 1000) :: UserID +-- 1000 +-- >>> review reviewUserIDWord32 42 :: UserID +-- 42 +instance ReviewUserID UserID where + reviewUserID = unto id + {-# INLINE reviewUserID #-} + +-- | Type class for values with a prism into a @UserID@. +-- +-- >>> preview _UserID (CUid 1000) +-- Just 1000 +class (ReviewUserID a) => AsUserID a where _UserID :: Prism' a UserID + {-# INLINE _UserIDWord32 #-} _UserIDWord32 :: Prism' a Word32 _UserIDWord32 = - _UserID . - iso + _UserID + . iso (\(CUid x) -> x) CUid +-- | +-- +-- >>> preview _UserID (CUid 1000) +-- Just 1000 +-- >>> preview _UserIDWord32 (CUid 1000) +-- Just 1000 +-- >>> review _UserIDWord32 42 :: UserID +-- 42 instance AsUserID UserID where _UserID = id diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} + +module Main (main) where + +import System.Exit (exitWith) +import System.Process (rawSystem) + +main :: IO () +main = + exitWith + =<< rawSystem + "cabal" + [ "repl", + "--with-compiler=doctest", + "--repl-options=-w", + "--repl-options=-Wdefault", + "lib:exitcode" + ] diff --git a/test/Tests.hs b/test/Tests.hs deleted file mode 100644 --- a/test/Tests.hs +++ /dev/null @@ -1,127 +0,0 @@ -import Control.Lens (review, (^.), (^?)) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import Data.Functor.Classes (Eq1) -import Data.Functor.Identity (Identity (..), runIdentity) -import Data.Monoid ((<>)) - -import Hedgehog (forAll, property, (===)) -import qualified Hedgehog.Gen as Gen -import Hedgehog.Internal.Gen (MonadGen) -import qualified Hedgehog.Range as Range -import Test.QuickCheck (Arbitrary) -import Test.QuickCheck.Checkers (EqProp (..), Test, TestBatch, eq) -import Test.QuickCheck.Classes (applicative, functor) -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.Hedgehog (testProperty) -import Test.Tasty.HUnit (testCase, (@?=)) -import qualified Test.Tasty.QuickCheck as TQC - -import Control.Exitcode (Exitcode, ExitcodeT, exitCode, - exitfailure0, exitsuccess, - exitsuccess0, runExitcode, - runExitcodeT, _ExitFailure, - _ExitSuccess, ExitcodeT0) - -import System.Exit (ExitCode (..)) - -newtype EW f e a = EW { unEW :: ExitcodeT f e a } deriving (Eq, Show) - -instance (Monad f, Arbitrary e, Arbitrary a) => Arbitrary (EW f e a) where - arbitrary = fmap (EW . pure) TQC.arbitrary - -instance Functor f => Functor (EW f e) where - fmap f = EW . fmap f . unEW - -instance Monad f => Applicative (EW f e) where - pure = EW . pure - EW f <*> EW a = EW (f <*> a) - -instance (Eq1 f, Eq e, Eq a) => EqProp (EW f e a) where - (=-=) = eq - -type CheckMe = EW [] String (Integer, Integer, Integer) - -nonZero :: MonadGen m => m Int -nonZero = - let allOfTheInts = Range.linear (minBound :: Int) (maxBound :: Int) - in Gen.filter (/= 0) (Gen.int allOfTheInts) - -main :: IO () -main = defaultMain test_Exitcode - -test_Exitcode :: TestTree -test_Exitcode = - testGroup "Exitcode" [ - tastyCheckersBatch $ functor (undefined :: CheckMe) - , tastyCheckersBatch $ applicative (undefined :: CheckMe) - , applicativeTest - , exitFailureTraversalTest - , exitSuccessPrismTest - , exitfailure0Test - , exitCodePrismTest - ] - -applicativeTest :: TestTree -applicativeTest = - testGroup "Applicative" [ - testCase "Sticks to the Right" $ - pure (<> "bar") <*> pure "foo" @?= (exitsuccess "foobar" :: Exitcode String String) - ] - -exitFailureTraversalTest :: TestTree -exitFailureTraversalTest = - testGroup "_ExitFailure Traversal" [ - testProperty "view non-zero input" . property $ - forAll nonZero >>= (\n -> (exitfailure0 n :: ExitcodeT0 Identity) ^? _ExitFailure === Just ((), n)) - , testCase "view 0" $ - (exitfailure0 0 :: ExitcodeT0 Identity) ^? _ExitFailure @?= Nothing - ] - -exitSuccessPrismTest :: TestTree -exitSuccessPrismTest = - testGroup "_ExitSuccess Prism" [ - testCase "review" $ - review _ExitSuccess () @?= (exitsuccess0 :: ExitcodeT Identity () ()) - , testCase "view exitsuccess0" $ - (exitsuccess0 :: ExitcodeT Identity () ()) ^? _ExitSuccess @?= Just () - , testProperty "view exitfailure0 non-zero" . property $ - forAll nonZero >>= (\n -> exitfailure0 n ^? _ExitSuccess === Nothing) - , testCase "view exitfailure0 0" $ - exitfailure0 0 ^? _ExitSuccess @?= Just () - ] - -exitfailure0Test :: TestTree -exitfailure0Test = - testGroup "exitfailure0" [ - testProperty "non-zero input" . property $ - forAll nonZero >>= (\n -> - runExitcode (exitfailure0 n) === Left ((), n)) - , testCase "0" $ - runExitcode (exitfailure0 0) @?= Right () - ] - -exitCodePrismTest :: TestTree -exitCodePrismTest = - testGroup "exitCode Prism" [ - testProperty "`exitfailure0 n`, where n is non-zero" . property $ - forAll nonZero >>= \n -> (review exitCode (exitfailure0 n)) === Identity (ExitFailure n) - , testCase "review `exitfailure 0`" $ - runIdentity (review exitCode (exitfailure0 0)) @?= ExitSuccess - , testCase "review `exitsuccess0`" $ - runIdentity (review exitCode exitsuccess0) @?= ExitSuccess - , testProperty "view ExitFailure n, where n is non-zero" . property $ - forAll nonZero >>= (\n -> Identity (ExitFailure n) ^? exitCode === Just (exitfailure0 n)) - , testCase "view ExitFailure 0" $ - let _ = "" - in runExitcodeT (Identity (ExitFailure 0) ^. exitCode) @?= (MaybeT (Identity Nothing)) - , testCase "view ExitSuccess" $ - Identity ExitSuccess ^? exitCode @?= Just exitsuccess0 - ] - -tastyCheckersBatch :: TestBatch -> TestTree -tastyCheckersBatch (name, tests) = - testGroup (name <> " laws") (tastyCheckersProperty <$> tests) - -tastyCheckersProperty :: Test -> TestTree -tastyCheckersProperty = - uncurry TQC.testProperty