diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2015 NICTA Limited + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,44 @@ +#!/usr/bin/env runhaskell +\begin{code} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Verbosity ( Verbosity ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + +\end{code} diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,4 @@ +0.1.0 + +* Initial version inspired by `system-command`. + diff --git a/src/Sys/CmdSpec.hs b/src/Sys/CmdSpec.hs new file mode 100644 --- /dev/null +++ b/src/Sys/CmdSpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Sys.CmdSpec( + CmdSpec(..) +, AsCmdSpec(..) +, AsExecutableName(..) +, AsExecutableArguments(..) +, AsShellCommand(..) +, AsRawCommand(..) +) where + +import Control.Applicative(Applicative) +import Control.Category(Category(id, (.))) +import Control.Lens(Optic', Choice, Profunctor, prism', iso, _1, _2) +import Data.Eq(Eq) +import Data.Functor(Functor) +import Data.Maybe(Maybe(Just, Nothing)) +import Data.Ord(Ord) +import Data.String(IsString(fromString), String) +import Data.Tuple(uncurry) +import Prelude(Show) +import System.FilePath(FilePath) +import qualified System.Process as Process + +data CmdSpec = + ShellCommand String + -- ^ A command line to execute using the shell + | RawCommand FilePath [String] + -- ^ The name of an executable with a list of arguments + -- + -- The 'FilePath' argument names the executable, and is interpreted + -- according to the platform's standard policy for searching for + -- executables. Specifically: + -- + -- * on Unix systems the + -- + -- semantics is used, where if the executable filename does not + -- contain a slash (@/@) then the @PATH@ environment variable is + -- searched for the executable. + -- + -- * on Windows systems the Win32 @CreateProcess@ semantics is used. + -- Briefly: if the filename does not contain a path, then the + -- directory containing the parent executable is searched, followed + -- by the current directory, then some standard locations, and + -- finally the current @PATH@. An @.exe@ extension is added if the + -- filename does not already have an extension. For full details + -- see the + -- + -- for the Windows @SearchPath@ API. + deriving (Eq, Ord, Show) + +instance IsString CmdSpec where + fromString = + ShellCommand + +class AsCmdSpec p f s where + _CmdSpec :: + Optic' p f s CmdSpec + +instance AsCmdSpec p f CmdSpec where + _CmdSpec = + id + +instance (Profunctor p, Functor f) => AsCmdSpec p f Process.CmdSpec where + _CmdSpec = + iso + (\c -> case c of + Process.ShellCommand s -> + ShellCommand s + Process.RawCommand p s -> + RawCommand p s) + (\c -> case c of + ShellCommand s -> + Process.ShellCommand s + RawCommand p s -> + Process.RawCommand p s) + +class AsExecutableName p f s where + _ExecutableName :: + Optic' p f s FilePath + +instance AsExecutableName p f FilePath where + _ExecutableName = + id + +instance Applicative f => AsExecutableName (->) f CmdSpec where + _ExecutableName = + _RawCommand . _1 + +class AsExecutableArguments p f s where + _ExecutableArguments :: + Optic' p f s [String] + +instance AsExecutableArguments p f [String] where + _ExecutableArguments = + id + +instance Applicative f => AsExecutableArguments (->) f CmdSpec where + _ExecutableArguments = + _RawCommand . _2 + +class AsShellCommand p f s where + _ShellCommand :: + Optic' p f s String + +instance AsShellCommand p f String where + _ShellCommand = + id + +instance (Choice p, Applicative f) => AsShellCommand p f CmdSpec where + _ShellCommand = + prism' + ShellCommand + (\c -> case c of + ShellCommand s -> + Just s + RawCommand _ _ -> + Nothing) + +class AsRawCommand p f s where + _RawCommand :: + Optic' p f s (FilePath, [String]) + +instance AsRawCommand p f (FilePath, [String]) where + _RawCommand = + id + +instance (Choice p, Applicative f) => AsRawCommand p f CmdSpec where + _RawCommand = + prism' + (uncurry RawCommand) + (\c -> case c of + ShellCommand _ -> + Nothing + RawCommand p s -> + Just (p, s)) diff --git a/src/Sys/CreateProcess.hs b/src/Sys/CreateProcess.hs new file mode 100644 --- /dev/null +++ b/src/Sys/CreateProcess.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Sys.CreateProcess( + CreateProcess(..) +, AsCreateProcess(..) +, AsWorkingDirectory(..) +, AsEnvironment(..) +, AsStdin(..) +, AsStdout(..) +, AsStderr(..) +, AsCloseDescriptors(..) +, AsCreateGroup(..) +, AsDelegateCtrlC(..) +) where + +import Control.Applicative(Applicative) +import Control.Category(Category(id, (.))) +import Control.Lens(Optic', Profunctor, lens, from, iso, (#)) +import Data.Bool(Bool) +import Data.Eq(Eq) +import Data.Functor(Functor) +import Data.Maybe(Maybe) +import Data.String(String) +import Prelude(Show) +import Sys.CmdSpec(CmdSpec, AsCmdSpec(_CmdSpec), AsExecutableName(_ExecutableName), AsExecutableArguments(_ExecutableArguments), AsShellCommand(_ShellCommand), AsRawCommand(_RawCommand)) +import Sys.StdStream(StdStream, AsStdStream(_StdStream)) +import System.FilePath(FilePath) +import qualified System.Process as Process + +data CreateProcess = + CreateProcess + CmdSpec -- ^ Executable & arguments, or shell command + (Maybe FilePath) -- ^ Optional path to the working directory for the new process + (Maybe [(String,String)]) -- ^ Optional environment (otherwise inherit from the current process) + StdStream -- ^ How to determine stdin + StdStream -- ^ How to determine stdout + StdStream -- ^ How to determine stderr + Bool -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit) + Bool -- ^ Create a new process group + Bool -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details). + -- + -- On Windows this has no effect. + -- + -- /Since: 1.2.0.0/ + + deriving (Eq, Show) + +class AsCreateProcess p f s where + _CreateProcess :: + Optic' p f s CreateProcess + +instance AsCreateProcess p f CreateProcess where + _CreateProcess = + id + +instance (Profunctor p, Functor f) => AsCreateProcess p f Process.CreateProcess where + _CreateProcess = + iso + (\(Process.CreateProcess s p e i o r d g c) -> + CreateProcess (from _CmdSpec # s) p e (from _StdStream # i) (from _StdStream # o) (from _StdStream # r) d g c) + (\(CreateProcess s p e i o r d g c) -> + Process.CreateProcess (_CmdSpec # s) p e (_StdStream # i) (_StdStream # o) (_StdStream # r) d g c) + +instance Functor f => AsCmdSpec (->) f CreateProcess where + _CmdSpec = + lens + (\(CreateProcess s _ _ _ _ _ _ _ _) -> s) + (\(CreateProcess _ p e i o r d g c) s -> CreateProcess s p e i o r d g c) + +instance Applicative f => AsExecutableName (->) f CreateProcess where + _ExecutableName = + _CmdSpec . _ExecutableName + +instance Applicative f => AsExecutableArguments (->) f CreateProcess where + _ExecutableArguments = + _CmdSpec . _ExecutableArguments + +instance Applicative f => AsShellCommand (->) f CreateProcess where + _ShellCommand = + _CmdSpec . _ShellCommand + +instance Applicative f => AsRawCommand (->) f CreateProcess where + _RawCommand = + _CmdSpec . _RawCommand + +class AsWorkingDirectory p f s where + _WorkingDirectory :: + Optic' p f s (Maybe FilePath) + +instance AsWorkingDirectory p f (Maybe FilePath) where + _WorkingDirectory = + id + +instance Functor f => AsWorkingDirectory (->) f CreateProcess where + _WorkingDirectory = + lens + (\(CreateProcess _ p _ _ _ _ _ _ _) -> p) + (\(CreateProcess s _ e i o r d g c) p -> CreateProcess s p e i o r d g c) + +class AsEnvironment p f s where + _Environment :: + Optic' p f s (Maybe [(String, String)]) + +instance AsEnvironment p f (Maybe [(String, String)]) where + _Environment = + id + +instance Functor f => AsEnvironment (->) f CreateProcess where + _Environment = + lens + (\(CreateProcess _ _ e _ _ _ _ _ _) -> e) + (\(CreateProcess s p _ i o r d g c) e -> CreateProcess s p e i o r d g c) + +class AsStdin p f s where + _Stdin :: + Optic' p f s StdStream + +instance AsStdin p f StdStream where + _Stdin = + id + +instance Functor f => AsStdin (->) f CreateProcess where + _Stdin = + lens + (\(CreateProcess _ _ _ i _ _ _ _ _) -> i) + (\(CreateProcess s p e _ o r d g c) i -> CreateProcess s p e i o r d g c) + +class AsStdout p f s where + _Stdout :: + Optic' p f s StdStream + +instance AsStdout p f StdStream where + _Stdout = + id + +instance Functor f => AsStdout (->) f CreateProcess where + _Stdout = + lens + (\(CreateProcess _ _ _ _ o _ _ _ _) -> o) + (\(CreateProcess s p e i _ r d g c) o -> CreateProcess s p e i o r d g c) + +class AsStderr p f s where + _Stderr :: + Optic' p f s StdStream + +instance AsStderr p f StdStream where + _Stderr = + id + +instance Functor f => AsStderr (->) f CreateProcess where + _Stderr = + lens + (\(CreateProcess _ _ _ _ _ r _ _ _) -> r) + (\(CreateProcess s p e i o _ d g c) r -> CreateProcess s p e i o r d g c) + +class AsCloseDescriptors p f s where + _CloseDescriptors :: + Optic' p f s Bool + +instance AsCloseDescriptors p f Bool where + _CloseDescriptors = + id + +instance Functor f => AsCloseDescriptors (->) f CreateProcess where + _CloseDescriptors = + lens + (\(CreateProcess _ _ _ _ _ _ d _ _) -> d) + (\(CreateProcess s p e i o r _ g c) d -> CreateProcess s p e i o r d g c) + +class AsCreateGroup p f s where + _CreateGroup :: + Optic' p f s Bool + +instance AsCreateGroup p f Bool where + _CreateGroup = + id + +instance Functor f => AsCreateGroup (->) f CreateProcess where + _CreateGroup = + lens + (\(CreateProcess _ _ _ _ _ _ _ g _) -> g) + (\(CreateProcess s p e i o r d _ c) g -> CreateProcess s p e i o r d g c) + +class AsDelegateCtrlC p f s where + _DelegateCtrlC :: + Optic' p f s Bool + +instance AsDelegateCtrlC p f Bool where + _DelegateCtrlC = + id + +instance Functor f => AsDelegateCtrlC (->) f CreateProcess where + _DelegateCtrlC = + lens + (\(CreateProcess _ _ _ _ _ _ _ _ c) -> c) + (\(CreateProcess s p e i o r d g _) c -> CreateProcess s p e i o r d g c) diff --git a/src/Sys/Exit.hs b/src/Sys/Exit.hs new file mode 100644 --- /dev/null +++ b/src/Sys/Exit.hs @@ -0,0 +1,76 @@ +module Sys.Exit( + module ExitCode +, module Process +, Process.ProcessHandle +-- * Exit +, exitWith +, exitWithFailure +, exitWithFailure1 +, exitWithSuccess +) where + +import Data.NotZero +import qualified System.Exit as Exit +import Sys.ExitCode +import Sys.Process as Process +import Sys.ExitCode as ExitCode +import System.IO +import qualified System.Process as Process +import Prelude + +-- --------------------------------------------------------------------------- +-- exitWith + +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. +-- Normally this terminates the program, returning @code@ to the +-- program's caller. +-- +-- On program termination, the standard 'Handle's 'stdout' and +-- 'stderr' are flushed automatically; any other buffered 'Handle's +-- need to be flushed manually, otherwise the buffered data will be +-- discarded. +-- +-- A program that fails in any other way is treated as if it had +-- called 'exitFailure'. +-- A program that terminates successfully without calling 'exitWith' +-- explicitly is treated as it it had called 'exitWith' 'ExitSuccess'. +-- +-- As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses +-- the error handling in the 'IO' monad and cannot be intercepted by +-- 'catch' from the "Prelude". However it is a 'SomeException', and can +-- be caught using the functions of "Control.Exception". This means +-- that cleanup computations added with 'Control.Exception.bracket' +-- (from "Control.Exception") are also executed properly on 'exitWith'. +-- +-- Note: in GHC, 'exitWith' should be called from the main program +-- thread in order to exit the process. When called from another +-- thread, 'exitWith' will throw an 'ExitException' as normal, but the +-- exception will not cause the process itself to exit. +-- +exitWith :: + ExitCode + -> IO a +exitWith = + Exit.exitWith . exitCode + +exitWithFailure :: + NotZero Int + -> IO a +exitWithFailure = + exitWith . exitFailure + +-- | The computation 'exitWithFailure1' is equivalent to +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@, +-- where /exitfail/ is implementation-dependent. +exitWithFailure1 :: + IO a +exitWithFailure1 = + exitWith (exitFailure notZero1) + +-- | The computation 'exitWithSuccess' is equivalent to +-- 'exitWith' 'ExitSuccess', It terminates the program +-- successfully. +exitWithSuccess :: + IO a +exitWithSuccess = + exitWith exitSuccess diff --git a/src/Sys/ExitCode.hs b/src/Sys/ExitCode.hs new file mode 100644 --- /dev/null +++ b/src/Sys/ExitCode.hs @@ -0,0 +1,82 @@ +module Sys.ExitCode( + ExitCode +, _ExitFailure +, _ExitSuccess +, exitFailure +, exitSuccess +, exitFailureP +, exitSuccessP +, exitCode +, unExitCode +) where + +import Control.Lens +import Data.Int(Int) +import Data.Maybe +import Data.NotZero +import Data.NotZeroOr +import qualified System.Exit as Exit + +type ExitCode = + Number Int + +_ExitFailure :: + Prism' ExitCode (NotZero Int) +_ExitFailure = + _IsNotZero + +_ExitSuccess :: + Prism' ExitCode () +_ExitSuccess = + _OrNotZero + +exitFailure :: + NotZero Int + -> ExitCode +exitFailure = + (_ExitFailure #) + +exitSuccess :: + ExitCode +exitSuccess = + _ExitSuccess # () + +exitFailureP :: + Prism' Exit.ExitCode Int +exitFailureP = + prism' + Exit.ExitFailure + (\x -> case x of + Exit.ExitFailure y -> + Just y + Exit.ExitSuccess -> + Nothing) + +exitSuccessP :: + Prism' Exit.ExitCode () +exitSuccessP = + prism' + (\() -> Exit.ExitSuccess) + (\x -> case x of + Exit.ExitFailure _ -> + Nothing + Exit.ExitSuccess -> + Just ()) + +exitCode :: + ExitCode + -> Exit.ExitCode +exitCode (IsNotZero a) = + Exit.ExitFailure (notZero # a) +exitCode (OrNotZero ()) = + Exit.ExitSuccess + +unExitCode :: + Exit.ExitCode + -> ExitCode +unExitCode (Exit.ExitSuccess) = + exitSuccess +unExitCode (Exit.ExitFailure 0) = + exitSuccess +unExitCode (Exit.ExitFailure n) = + exitFailure (notZeroElse notZero1 n) diff --git a/src/Sys/Process.hs b/src/Sys/Process.hs new file mode 100644 --- /dev/null +++ b/src/Sys/Process.hs @@ -0,0 +1,121 @@ +module Sys.Process( + module CmdSpec +, module CreateProcess +, module StdStream +-- * Running sub-processes +, createProcess +, createProcess_ +, shell +, proc +-- ** Simpler functions for common tasks +, Process.callProcess +, Process.callCommand +, Process.spawnProcess +, Process.spawnCommand +, readCreateProcess +, Process.readProcess +, readCreateProcessWithExitCode +, readProcessWithExitCode +-- ** Related utilities +, Process.showCommandForUser +-- ** Control-C handling on Unix +-- $ctlc-handling +-- * Process completion +, waitForProcess +, getProcessExitCode +, Process.terminateProcess +, Process.interruptProcessGroupOf +-- * Interprocess communication +, Process.createPipe +) where + +{- + + -- ** Related utilities + showCommandForUser, + + -- ** Control-C handling on Unix + -- $ctlc-handling + + -- * Process completion + waitForProcess, + getProcessExitCode, + terminateProcess, + interruptProcessGroupOf, + + -- Interprocess communication +-} + +import Control.Category(Category((.))) +import Control.Lens((#), (%~), (^.), _1) +import Data.Functor(Functor(fmap)) +import Data.Maybe(Maybe) +import Data.String(String) +import Sys.CmdSpec as CmdSpec +import Sys.CreateProcess as CreateProcess +import Sys.StdStream as StdStream +import Sys.ExitCode(ExitCode, unExitCode) +import System.FilePath(FilePath) +import System.IO(Handle, IO) +import qualified System.Process as Process +import Prelude() + +createProcess :: + CreateProcess + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, Process.ProcessHandle) +createProcess = + Process.createProcess . (_CreateProcess #) + +createProcess_ :: + String + -> CreateProcess + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, Process.ProcessHandle) +createProcess_ s = + Process.createProcess_ s . (_CreateProcess #) + +shell :: + String + -> CreateProcess +shell s = + Process.shell s ^. _CreateProcess + +proc :: + FilePath + -> [String] + -> CreateProcess +proc p s = + Process.proc p s ^. _CreateProcess + +readCreateProcess :: + CreateProcess + -> String + -> IO String +readCreateProcess = + Process.readCreateProcess . (_CreateProcess #) + +readCreateProcessWithExitCode :: + CreateProcess + -> String + -> IO (ExitCode, String, String) +readCreateProcessWithExitCode p = + fmap (_1 %~ unExitCode) . Process.readCreateProcessWithExitCode (_CreateProcess # p) + +readProcessWithExitCode :: + FilePath + -> [String] + -> String + -> IO (ExitCode, String, String) +readProcessWithExitCode f a = + fmap (_1 %~ unExitCode) . Process.readProcessWithExitCode f a + +waitForProcess :: + Process.ProcessHandle + -> IO ExitCode +waitForProcess = + fmap unExitCode . Process.waitForProcess + +getProcessExitCode :: + Process.ProcessHandle + -> IO (Maybe ExitCode) +getProcessExitCode = + fmap (fmap unExitCode) . Process.getProcessExitCode diff --git a/src/Sys/StdStream.hs b/src/Sys/StdStream.hs new file mode 100644 --- /dev/null +++ b/src/Sys/StdStream.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Sys.StdStream( + StdStream(..) +, AsStdStream(..) +, AsInherit(..) +, AsUseHandle(..) +, AsCreatePipe +) where + +import Control.Applicative(Applicative) +import Control.Category(Category(id)) +import Control.Lens(Optic', Choice, Profunctor, prism', iso) +import Data.Maybe +import Data.Eq(Eq) +import Data.Functor(Functor) +import Prelude(Show) +import System.IO(Handle) +import qualified System.Process as Process + +data StdStream = + Inherit -- ^ Inherit Handle from parent + | UseHandle Handle -- ^ Use the supplied Handle + | CreatePipe -- ^ Create a new pipe. The returned + -- @Handle@ will use the default encoding + -- and newline translation mode (just + -- like @Handle@s created by @openFile@). + deriving (Eq, Show) + +class AsStdStream p f s where + _StdStream :: + Optic' p f s StdStream + +instance AsStdStream p f StdStream where + _StdStream = + id + +instance (Profunctor p, Functor f) => AsStdStream p f Process.StdStream where + _StdStream = + iso + (\s -> case s of + Process.Inherit -> + Inherit + Process.UseHandle h -> + UseHandle h + Process.CreatePipe -> + CreatePipe) + (\s -> case s of + Inherit -> + Process.Inherit + UseHandle h -> + Process.UseHandle h + CreatePipe -> + Process.CreatePipe) + +class AsInherit p f s where + _Inherit :: + Optic' p f s () + +instance AsInherit p f () where + _Inherit = + id + +instance (Choice p, Applicative f) => AsInherit p f StdStream where + _Inherit = + prism' + (\() -> Inherit) + (\s -> case s of + Inherit -> + Just () + UseHandle _ -> + Nothing + CreatePipe -> + Nothing) + +class AsUseHandle p f s where + _UseHandle :: + Optic' p f s Handle + +instance AsUseHandle p f Handle where + _UseHandle = + id + +instance (Choice p, Applicative f) => AsUseHandle p f StdStream where + _UseHandle = + prism' + UseHandle + (\s -> case s of + Inherit -> + Nothing + UseHandle h -> + Just h + CreatePipe -> + Nothing) + +class AsCreatePipe p f s where + _CreatePipe :: + Optic' p f s () + +instance AsCreatePipe p f () where + _CreatePipe = + id + +instance (Choice p, Applicative f) => AsCreatePipe p f StdStream where + _CreatePipe = + prism' + (\() -> CreatePipe) + (\s -> case s of + Inherit -> + Nothing + UseHandle _ -> + Nothing + CreatePipe -> + Just ()) diff --git a/sys-process.cabal b/sys-process.cabal new file mode 100644 --- /dev/null +++ b/sys-process.cabal @@ -0,0 +1,83 @@ +name: sys-process +version: 0.1.0 +license: BSD3 +license-file: LICENSE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +copyright: Copyright (C) 2015 NICTA Limited +synopsis: A replacement for System.Exit and System.Process. +category: Data, Numeric +description: + <> + . + A replacement for System.Exit and System.Process. +homepage: https://github.com/NICTA/sys-process +bug-reports: https://github.com/NICTA/sys-process/issues +cabal-version: >= 1.10 +build-type: Custom +extra-source-files: changelog + +source-repository head + type: git + location: git@github.com:NICTA/sys-process.git + +flag small_base + description: Choose the new, split-up base package. + +library + default-language: + Haskell2010 + + build-depends: + base >= 3 && < 5 + , mtl >= 2.0 && < 2.3 + , semigroups >= 0.8 + , semigroupoids >= 4.0 + , bifunctors >= 3.0 + , lens >= 4.0 && < 5 + , transformers >= 0.3 && < 0.5 + , process >= 1.2.3 && < 1.3 + , notzero >= 0.0.7 && <= 0.1 + , filepath >= 1.4 && < 2.0 + + ghc-options: + -Wall + + default-extensions: + NoImplicitPrelude + + hs-source-dirs: + src + + exposed-modules: + Sys.CmdSpec + Sys.CreateProcess + Sys.Exit + Sys.Process + Sys.StdStream + Sys.ExitCode + +test-suite doctests + type: + exitcode-stdio-1.0 + + main-is: + doctests.hs + + default-language: + Haskell2010 + + build-depends: + base < 5 && >= 3 + , doctest >= 0.9.7 + , filepath >= 1.3 + , directory >= 1.1 + , QuickCheck >= 2.0 + , template-haskell >= 2.8 + + ghc-options: + -Wall + -threaded + + hs-source-dirs: + test diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,32 @@ +module Main where + +import Build_doctests (deps) +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.FilePath +import Test.DocTest + +main :: + IO () +main = + getSources >>= \sources -> doctest $ + "-isrc" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : map ("-package="++) deps ++ sources + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c