diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +0.1.0.6 + +* Implement `ExitcodeT1` which associates the same type of value +* Implement functions over `System.Process` to use exitcode + 0.1.0.5 * Large refactor, involving an associated value with an exit failure. diff --git a/exitcode.cabal b/exitcode.cabal --- a/exitcode.cabal +++ b/exitcode.cabal @@ -1,42 +1,56 @@ -- documentation, see http://haskell.org/cabal/users-guide/ -name: exitcode -version: 0.1.0.5 -synopsis: Monad transformer for exit codes +name: exitcode +version: 0.1.0.6 +synopsis: Monad transformer for exit codes description: <> . Monad transformer for exit codes -license: BSD3 -license-file: LICENCE -author: Queensland Functional Programming Lab -maintainer: Tony Morris -copyright: Copyright (C) 2019-2022 Tony Morris -category: Control -build-type: Simple -extra-source-files: changelog.md -cabal-version: >=1.10 -homepage: https://github.com/system-f/exitcode -bug-reports: https://github.com/system-f/exitcode/issues -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 +license: BSD3 +license-file: LICENCE +author: Queensland Functional Programming Lab +maintainer: Tony Morris +copyright: Copyright (C) 2019-2022 Tony Morris +category: Control +build-type: Simple +extra-source-files: changelog.md +cabal-version: >=1.10 +homepage: https://github.com/system-f/exitcode +bug-reports: https://github.com/system-f/exitcode/issues +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 -source-repository head - type: git - location: git@github.com:system-f/exitcode.git +source-repository head + type: git + location: git@github.com:system-f/exitcode.git library - exposed-modules: Control.Exitcode - build-depends: base >= 4.8 && < 6 - , bifunctors >= 5 && < 6 - , lens >= 4.15 && < 6 - , mtl >= 2.2 && < 2.3 - , semigroupoids >= 5.1 && < 5.4 - , semigroups >= 0.16 && < 0.19 - , transformers >= 0.5.0 && < 5.5 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + exposed-modules: Control.Exitcode + Control.Process + Control.Process.CmdSpec + Control.Process.CreateProcess + Control.Process.FD + 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 + , filepath >= 1.4 && < 2 + , lens >= 4.15 && < 6 + , mtl >= 2.2 && < 2.3 + , process >= 1.6.12.0 && < 2 + , semigroupoids >= 5.1 && < 5.4 + , semigroups >= 0.16 && < 0.19 + , transformers >= 0.5.0 && < 5.5 + 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 @@ -45,6 +59,8 @@ , 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 diff --git a/src/Control/Exitcode.hs b/src/Control/Exitcode.hs --- a/src/Control/Exitcode.hs +++ b/src/Control/Exitcode.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} module Control.Exitcode ( -- * Types @@ -12,6 +13,8 @@ , Exitcode , ExitcodeT0 , Exitcode0 +, ExitcodeT1 +, Exitcode1 -- * Construction , exitsuccess , exitsuccess0 @@ -24,11 +27,16 @@ , liftExitcode , liftExitcodeError , liftExitcodeError0 +, hoistExitcode +, embedExitcode +, exitcode1 -- * Extraction , runExitcodeT , runExitcodeT0 , runExitcode , runExitcode0 +, runExitcodeT1 +, runExitcode1 -- * Optics , exitCode , _ExitcodeInt @@ -36,27 +44,27 @@ , _ExitFailure , _ExitFailureError , _ExitSuccess +, _Exitcode1 ) where import Control.Applicative ( Applicative((<*>), pure, liftA2) ) import Control.Category ( Category((.)) ) import Control.Lens - ( Identity(runIdentity), - preview, + ( preview, view, iso, _Left, prism, - mapped, over, Field1(_1), Field2(_2), Iso, + Lens, Prism, - Setter', - Traversal ) -import Control.Monad ( Monad(return, (>>=)) ) + Traversal, + Traversal' ) +import Control.Monad ( join, Monad(return, (>>=)) ) import Control.Monad.Cont.Class ( MonadCont(..) ) import Control.Monad.Error.Class ( MonadError(..) ) import Control.Monad.IO.Class ( MonadIO(..) ) @@ -86,7 +94,7 @@ Ord1(..), Show1(..) ) import Data.Functor.Extend ( Extend(..) ) -import Data.Functor.Identity ( Identity(Identity) ) +import Data.Functor.Identity ( Identity(Identity, runIdentity) ) import Data.Int ( Int ) import Data.Maybe ( Maybe(Nothing, Just), fromMaybe ) import Data.Monoid ( Monoid(mempty) ) @@ -328,19 +336,25 @@ -- | Setter to integer. -- --- >>> over _ExitcodeInt' (subtract 1) (exitsuccess0) :: ExitcodeT0 Identity +-- >>> > preview _ExitcodeInt' (exitsuccess0 :: ExitcodeT [] () ()) +-- Just 0 +-- >>> preview _ExitcodeInt' (exitfailure0 99 :: ExitcodeT [] () ()) +-- Just 99 +-- >>> preview _ExitcodeInt' (exitfailure0 0 :: ExitcodeT [] () ()) +-- 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' :: - (Functor f) => - Setter' + Traversable f => + Traversal' (ExitcodeT0 f) Int _ExitcodeInt' = - _ExitcodeInt . mapped + _ExitcodeInt . traverse -- | A traversal to exit failure. -- @@ -572,6 +586,21 @@ liftExitcodeError0 x = liftExitcodeError (((),) <$> 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 @@ -651,3 +680,85 @@ 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 (exitfailure () 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 (exitfailure () 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 + +-- | 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 diff --git a/src/Control/Process.hs b/src/Control/Process.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Control.Process( + module P +) where + +import Control.Process.CmdSpec as P +import Control.Process.CreateProcess as P +import Control.Process.FD as P +import Control.Process.GroupID as P +import Control.Process.Handle as P +import Control.Process.Pid as P +import Control.Process.Process as P +import Control.Process.ProcessHandle as P +import Control.Process.StdStream as P +import Control.Process.UserID as P diff --git a/src/Control/Process/CmdSpec.hs b/src/Control/Process/CmdSpec.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/CmdSpec.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Control.Process.CmdSpec( + AsCmdSpec(..) +, HasCmdSpec(..) +) where + +import Control.Category ( 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(..) ) + +class AsCmdSpec a where + _CmdSpec :: + Prism' a CmdSpec + _ShellCommand :: + Prism' a String + _ShellCommand = + _CmdSpec . _ShellCommand + _RawCommand :: + Prism' 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 AsCmdSpec CmdSpec where + _CmdSpec = id + _ShellCommand = + prism' + ShellCommand + (\case + ShellCommand a -> Just a + _ -> Nothing + ) + _RawCommand = + prism' + (uncurry RawCommand) + (\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 new file mode 100644 --- /dev/null +++ b/src/Control/Process/CreateProcess.hs @@ -0,0 +1,217 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Control.Process.CreateProcess( + HasCreateProcess(..) +, AsCreateProcess(..) +, streams +, streams1 +) where + +import Control.Applicative ( Applicative((<*>)) ) +import Control.Category ( 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) + +class HasCreateProcess a where + create_process :: + Lens' a CreateProcess + child_group :: + Lens' a (Maybe GroupID) + {-# INLINE child_group #-} + child_group = + create_process . child_group + child_user :: + Lens' a (Maybe UserID) + {-# INLINE child_user #-} + child_user = + create_process . child_user + close_fds :: + Lens' a Bool + {-# INLINE close_fds #-} + close_fds = + create_process . close_fds + create_group :: + Lens' a Bool + {-# INLINE create_group #-} + create_group = + create_process . create_group + create_new_console :: + Lens' a Bool + {-# INLINE create_new_console #-} + create_new_console = + create_process . create_new_console + cwd :: + Lens' a (Maybe FilePath) + {-# INLINE cwd #-} + cwd = + create_process . cwd + delegate_ctlc :: + Lens' a Bool + {-# INLINE delegate_ctlc #-} + delegate_ctlc = + create_process . delegate_ctlc + detach_console :: + Lens' a Bool + {-# INLINE detach_console #-} + detach_console = + create_process . detach_console + env :: + Lens' a (Maybe [(String, String)]) + {-# INLINE env #-} + env = + create_process . env + new_session :: + Lens' a Bool + {-# INLINE new_session #-} + new_session = + create_process . new_session + std_err :: + Lens' a StdStream + {-# INLINE std_err #-} + std_err = + create_process . std_err + std_in :: + Lens' a StdStream + {-# INLINE std_in #-} + std_in = + create_process . std_in + std_out :: + Lens' a StdStream + {-# INLINE std_out #-} + std_out = + create_process . std_out + use_process_jobs :: + Lens' a Bool + {-# INLINE use_process_jobs #-} + use_process_jobs = + create_process . use_process_jobs + + cwd' :: + Traversal' a FilePath + cwd' = + cwd . _Just + envList :: + Traversal' a [(String, String)] + envList = + env . _Just + envElement :: + Traversal' a (String, String) + envElement = + envList . traverse + envElementKey :: + Traversal' a String + envElementKey = + envElement . _1 + envElementValue :: + Traversal' a String + envElementValue = + envElement . _2 + close_fds' :: + Traversal' a () + close_fds' = + close_fds . only True + create_group' :: + Traversal' a () + create_group' = + create_group . only True + delegate_ctlc' :: + Traversal' a () + delegate_ctlc' = + delegate_ctlc . only True + detach_console' :: + Traversal' a () + detach_console' = + detach_console . only True + create_new_console' :: + Traversal' a () + create_new_console' = + create_new_console . only True + new_session' :: + Traversal' a () + new_session' = + new_session . only True + child_group' :: + Traversal' a GroupID + child_group' = + child_group . _Just + child_user' :: + Traversal' a UserID + child_user' = + child_user . _Just + child_user'' :: + Traversal' a Word32 + child_user'' = + child_user' . userIDWord32 + use_process_jobs' :: + Traversal' a () + use_process_jobs' = + use_process_jobs . only True + +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 (\upj' -> CreateProcess csc cw en sti sto ste clf crg dct dcl cnc nss chg chu upj') (f upj) + +class AsCreateProcess a where + _CreateProcess :: + Prism' a CreateProcess + +instance AsCreateProcess CreateProcess where + _CreateProcess = + id + +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 + +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 diff --git a/src/Control/Process/FD.hs b/src/Control/Process/FD.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/FD.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Control.Process.FD( + HasFD(..) +, 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 ) + +class HasFD a where + fd :: + Lens' a FD + fdInt32 :: + Lens' a Int32 + fdInt32 = + fd . + iso + (\(CInt x) -> x) + CInt + +instance HasFD FD where + fd = + id + +class AsFD a where + _FD :: + Prism' a FD + _FDInt32 :: + Prism' a Int32 + _FDInt32 = + _FD . + iso + (\(CInt x) -> x) + CInt + +instance AsFD FD where + _FD = + id diff --git a/src/Control/Process/GroupID.hs b/src/Control/Process/GroupID.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/GroupID.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Control.Process.GroupID( + HasGroupID(..) +, AsGroupID(..) +) where + +import Control.Category(id) +import Control.Lens ( Lens', Prism' ) +import System.Process.Internals ( GroupID ) + +class HasGroupID a where + groupID :: + Lens' a GroupID + +instance HasGroupID GroupID where + groupID = + id + +class AsGroupID a where + _GroupID :: + Prism' a GroupID + +instance AsGroupID GroupID where + _GroupID = + id diff --git a/src/Control/Process/Handle.hs b/src/Control/Process/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/Handle.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Control.Process.Handle( + HasHandle(..) +, 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) ) + +class HasHandle a where + handle :: + Lens' a Handle + +instance HasHandle Handle where + handle = + id + +class AsHandle a where + _Handle :: + Prism' a Handle + +instance AsHandle Handle where + _Handle = + id + +instance AsHandle StdStream where + _Handle = + prism' + UseHandle + (\case + UseHandle a -> Just a + _ -> Nothing + ) diff --git a/src/Control/Process/Pid.hs b/src/Control/Process/Pid.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/Pid.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Control.Process.Pid( + HasPid(..) +, 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 ) + +class HasPid a where + pid :: + Lens' a Pid + pidInt32 :: + Lens' a Int32 + pidInt32 = + pid . + iso + (\(CPid x) -> x) + CPid + +instance HasPid Pid where + pid = + id + +class AsPid a where + _Pid :: + Prism' a Pid + _PidInt32 :: + Prism' a Int32 + _PidInt32 = + _Pid . + iso + (\(CPid x) -> x) + CPid + +instance AsPid Pid where + _Pid = + id diff --git a/src/Control/Process/Process.hs b/src/Control/Process/Process.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/Process.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Control.Process.Process( + module Process +, readCreateProcessWithExitCode +, readProcessWithExitCode +, waitForProcess +, getProcessExitCode +) where + +import Control.Applicative ( Applicative(pure) ) +import Control.Category ( Category((.)) ) +import Control.Exitcode + ( ExitcodeT0, + fromExitCode', + liftExitcode, + ExitcodeT1, + _Exitcode1, + hoistExitcode ) +import Control.Lens ( Identity(runIdentity), set ) +import Control.Monad ( Monad((>>=)) ) +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 + ) +import qualified System.Process as P(readCreateProcessWithExitCode, readProcessWithExitCode, waitForProcess, getProcessExitCode) +import Control.Monad.Trans.Maybe ( MaybeT(MaybeT) ) + +readCreateProcessWithExitCode :: + CreateProcess + -> String + -> ExitcodeT1 IO (String, String) +readCreateProcessWithExitCode p a = + liftExitcode (P.readCreateProcessWithExitCode p a) >>= \(x, y, z) -> + hoistExitcode (pure . runIdentity) (set _Exitcode1 (y, z) (fromExitCode' x)) + +readProcessWithExitCode :: + FilePath + -> [String] + -> String + -> ExitcodeT1 IO (String, String) +readProcessWithExitCode p a i = + liftExitcode (P.readProcessWithExitCode p a i) >>= \(x, y, z) -> + hoistExitcode (pure . runIdentity) (set _Exitcode1 (y, z) (fromExitCode' x)) + +waitForProcess :: + ProcessHandle + -> ExitcodeT0 IO +waitForProcess h = + liftExitcode (P.waitForProcess h) >>= \x -> + hoistExitcode (pure . runIdentity) (fromExitCode' x) + +getProcessExitCode :: + ProcessHandle + -> ExitcodeT0 (MaybeT IO) +getProcessExitCode h = + liftExitcode (MaybeT (P.getProcessExitCode h)) >>= + hoistExitcode (pure . runIdentity) . fromExitCode' diff --git a/src/Control/Process/ProcessHandle.hs b/src/Control/Process/ProcessHandle.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/ProcessHandle.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Control.Process.ProcessHandle( + HasProcessHandle(..) +, AsProcessHandle(..) +) where + +import Control.Category(id) +import System.Process ( ProcessHandle ) +import Control.Lens ( Lens', Prism' ) + +class HasProcessHandle a where + processHandle :: + Lens' a ProcessHandle + +instance HasProcessHandle ProcessHandle where + processHandle = + id + +class AsProcessHandle a where + _ProcessHandle :: + Prism' a ProcessHandle + +instance AsProcessHandle ProcessHandle where + _ProcessHandle = + id diff --git a/src/Control/Process/StdStream.hs b/src/Control/Process/StdStream.hs new file mode 100644 --- /dev/null +++ b/src/Control/Process/StdStream.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Control.Process.StdStream( + StdStream(..) +, AsStdStream(..) +, HasStdStream(..) +) where + +import Control.Category ( Category(id, (.)) ) +import Control.Lens ( prism', Lens', Prism' ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import System.Process ( StdStream(..) ) + +class AsStdStream a where + _StdStream :: + Prism' a StdStream + _Inherit :: + Prism' a () + _Inherit = + _StdStream . _Inherit + _CreatePipe :: + Prism' a () + _CreatePipe = + _StdStream . _CreatePipe + _NoStream :: + Prism' a () + _NoStream = + _StdStream . _NoStream + +instance AsStdStream StdStream where + _StdStream = + id + _Inherit = + prism' + (\() -> Inherit) + (\case + Inherit -> Just () + _ -> Nothing + ) + _CreatePipe = + prism' + (\() -> CreatePipe) + (\case + CreatePipe -> Just () + _ -> Nothing + ) + _NoStream = + prism' + (\() -> NoStream) + (\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 new file mode 100644 --- /dev/null +++ b/src/Control/Process/UserID.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Control.Process.UserID( + HasUserID(..) +, 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 ) + +class HasUserID a where + userID :: + Lens' a UserID + userIDWord32 :: + Lens' a Word32 + userIDWord32 = + userID . + iso + (\(CUid x) -> x) + CUid + +instance HasUserID UserID where + userID = + id + +class AsUserID a where + _UserID :: + Prism' a UserID + _UserIDWord32 :: + Prism' a Word32 + _UserIDWord32 = + _UserID . + iso + (\(CUid x) -> x) + CUid + +instance AsUserID UserID where + _UserID = + id diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -19,26 +19,27 @@ import Control.Exitcode (Exitcode, ExitcodeT, exitCode, exitfailure0, exitsuccess, exitsuccess0, runExitcode, - _ExitFailure, _ExitSuccess) + runExitcodeT, _ExitFailure, + _ExitSuccess, ExitcodeT0) import System.Exit (ExitCode (..)) -newtype EW f a = EW { unEW :: ExitcodeT f a } deriving (Eq, Show) +newtype EW f e a = EW { unEW :: ExitcodeT f e a } deriving (Eq, Show) -instance (Monad f, Arbitrary a) => Arbitrary (EW f a) where +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) where +instance Functor f => Functor (EW f e) where fmap f = EW . fmap f . unEW -instance Monad f => Applicative (EW f) where +instance Monad f => Applicative (EW f e) where pure = EW . pure EW f <*> EW a = EW (f <*> a) -instance (Eq1 f, Eq a) => EqProp (EW f a) where +instance (Eq1 f, Eq e, Eq a) => EqProp (EW f e a) where (=-=) = eq -type CheckMe = EW [] (Integer, Integer, Integer) +type CheckMe = EW [] String (Integer, Integer, Integer) nonZero :: MonadGen m => m Int nonZero = @@ -54,7 +55,7 @@ tastyCheckersBatch $ functor (undefined :: CheckMe) , tastyCheckersBatch $ applicative (undefined :: CheckMe) , applicativeTest - , exitFailurePrismTest + , exitFailureTraversalTest , exitSuccessPrismTest , exitfailure0Test , exitCodePrismTest @@ -64,29 +65,25 @@ applicativeTest = testGroup "Applicative" [ testCase "Sticks to the Right" $ - pure (<> "bar") <*> pure "foo" @?= (exitsuccess "foobar" :: Exitcode String) + pure (<> "bar") <*> pure "foo" @?= (exitsuccess "foobar" :: Exitcode String String) ] -exitFailurePrismTest :: TestTree -exitFailurePrismTest = - testGroup "_ExitFailure Prism" [ - testProperty "review non-zero input" . property $ - forAll nonZero >>= (\n -> review _ExitFailure n === exitfailure0 n) - , testCase "review 0" $ - review _ExitFailure 0 @?= exitsuccess0 - , testProperty "view non-zero input" . property $ - forAll nonZero >>= (\n -> exitfailure0 n ^? _ExitFailure === Just n) +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 ^? _ExitFailure @?= Nothing + (exitfailure0 0 :: ExitcodeT0 Identity) ^? _ExitFailure @?= Nothing ] exitSuccessPrismTest :: TestTree exitSuccessPrismTest = testGroup "_ExitSuccess Prism" [ testCase "review" $ - review _ExitSuccess () @?= exitsuccess0 + review _ExitSuccess () @?= (exitsuccess0 :: ExitcodeT Identity () ()) , testCase "view exitsuccess0" $ - exitsuccess0 ^? _ExitSuccess @?= Just () + (exitsuccess0 :: ExitcodeT Identity () ()) ^? _ExitSuccess @?= Just () , testProperty "view exitfailure0 non-zero" . property $ forAll nonZero >>= (\n -> exitfailure0 n ^? _ExitSuccess === Nothing) , testCase "view exitfailure0 0" $ @@ -97,9 +94,10 @@ exitfailure0Test = testGroup "exitfailure0" [ testProperty "non-zero input" . property $ - forAll nonZero >>= (\n -> (runIdentity . runExitcode) (exitfailure0 n) === Left n) + forAll nonZero >>= (\n -> + runExitcode (exitfailure0 n) === Left ((), n)) , testCase "0" $ - (runIdentity . runExitcode) (exitfailure0 0) @?= Right () + runExitcode (exitfailure0 0) @?= Right () ] exitCodePrismTest :: TestTree @@ -114,7 +112,8 @@ , testProperty "view ExitFailure n, where n is non-zero" . property $ forAll nonZero >>= (\n -> Identity (ExitFailure n) ^? exitCode === Just (exitfailure0 n)) , testCase "view ExitFailure 0" $ - runExitcode (Identity (ExitFailure 0) ^. exitCode) @?= (MaybeT (Identity Nothing)) + let _ = "" + in runExitcodeT (Identity (ExitFailure 0) ^. exitCode) @?= (MaybeT (Identity Nothing)) , testCase "view ExitSuccess" $ Identity ExitSuccess ^? exitCode @?= Just exitsuccess0 ]