{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances, TypeOperators, ScopedTypeVariables, NamedFieldPuns #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable, RecordWildCards #-}


-- | This module provides functions for calling command line programs, primarily
--   'command' and 'cmd'. As a simple example:
--
-- @
-- 'command' [] \"gcc\" [\"-c\",myfile]
-- @
--
--   The functions from this module are now available directly from "Development.Shake".
--   You should only need to import this module if you are using the 'cmd' function in the 'IO' monad.
module Development.Shake.Command(
    command, command_, cmd, cmd_, unit, CmdArgument(..), CmdArguments(..), IsCmdArgument(..), (:->),
    Stdout(..), StdoutTrim(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..), FSATrace(..),
    CmdResult, CmdString, CmdOption(..),
    addPath, addEnv,
    ) where

import Data.Tuple.Extra
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.Exception.Extra
import Data.Char
import Data.Either.Extra
import Data.Foldable (toList)
import Data.List.Extra
import Data.List.NonEmpty (NonEmpty)
import qualified Data.HashSet as Set
import Data.Maybe
import Data.Data
import Data.Semigroup
import System.Directory
import qualified System.IO.Extra as IO
import System.Environment
import System.Exit
import System.IO.Extra hiding (withTempFile, withTempDir)
import System.Process
import System.Info.Extra
import System.Time.Extra
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.UTF8 as UTF8
import General.Extra
import General.Process
import Prelude

import Development.Shake.Internal.CmdOption
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Types hiding (Result)
import Development.Shake.FilePath
import Development.Shake.Internal.Options
import Development.Shake.Internal.Rules.File
import Development.Shake.Internal.Derived

---------------------------------------------------------------------
-- ACTUAL EXECUTION

-- | /Deprecated:/ Use 'AddPath'. This function will be removed in a future version.
--
--   Add a prefix and suffix to the @$PATH@ environment variable. For example:
--
-- @
-- opt <- 'addPath' [\"\/usr\/special\"] []
-- 'cmd' opt \"userbinary --version\"
-- @
--
--   Would prepend @\/usr\/special@ to the current @$PATH@, and the command would pick
--   @\/usr\/special\/userbinary@, if it exists. To add other variables see 'addEnv'.
addPath :: MonadIO m => [String] -> [String] -> m CmdOption
addPath :: [String] -> [String] -> m CmdOption
addPath [String]
pre [String]
post = do
    [(String, String)]
args <- IO [(String, String)] -> m [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
    let ([(String, String)]
path,[(String, String)]
other) = ((String, String) -> Bool)
-> [(String, String)] -> ([(String, String)], [(String, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"PATH") (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isWindows then String -> String
upper else String -> String
forall a. a -> a
id) (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
args
    CmdOption -> m CmdOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmdOption -> m CmdOption) -> CmdOption -> m CmdOption
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> CmdOption
Env ([(String, String)] -> CmdOption)
-> [(String, String)] -> CmdOption
forall a b. (a -> b) -> a -> b
$
        [(String
"PATH",String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
pre [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
post) | [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
path] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++
        [(String
a,String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
pre [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
b | String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
post) | (String
a,String
b) <- [(String, String)]
path] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++
        [(String, String)]
other

-- | /Deprecated:/ Use 'AddEnv'. This function will be removed in a future version.
--
--   Add a single variable to the environment. For example:
--
-- @
-- opt <- 'addEnv' [(\"CFLAGS\",\"-O2\")]
-- 'cmd' opt \"gcc -c main.c\"
-- @
--
--   Would add the environment variable @$CFLAGS@ with value @-O2@. If the variable @$CFLAGS@
--   was already defined it would be overwritten. If you wish to modify @$PATH@ see 'addPath'.
addEnv :: MonadIO m => [(String, String)] -> m CmdOption
addEnv :: [(String, String)] -> m CmdOption
addEnv [(String, String)]
extra = do
    [(String, String)]
args <- IO [(String, String)] -> m [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
    CmdOption -> m CmdOption
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmdOption -> m CmdOption) -> CmdOption -> m CmdOption
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> CmdOption
Env ([(String, String)] -> CmdOption)
-> [(String, String)] -> CmdOption
forall a b. (a -> b) -> a -> b
$ [(String, String)]
extra [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
a,String
_) -> String
a String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
extra) [(String, String)]
args


data Str = Str String | BS BS.ByteString | LBS LBS.ByteString | Unit deriving (Str -> Str -> Bool
(Str -> Str -> Bool) -> (Str -> Str -> Bool) -> Eq Str
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Str -> Str -> Bool
$c/= :: Str -> Str -> Bool
== :: Str -> Str -> Bool
$c== :: Str -> Str -> Bool
Eq,Int -> Str -> String -> String
[Str] -> String -> String
Str -> String
(Int -> Str -> String -> String)
-> (Str -> String) -> ([Str] -> String -> String) -> Show Str
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Str] -> String -> String
$cshowList :: [Str] -> String -> String
show :: Str -> String
$cshow :: Str -> String
showsPrec :: Int -> Str -> String -> String
$cshowsPrec :: Int -> Str -> String -> String
Show)

strTrim :: Str -> Str
strTrim :: Str -> Str
strTrim (Str String
x) = String -> Str
Str (String -> Str) -> String -> Str
forall a b. (a -> b) -> a -> b
$ String -> String
trim String
x
strTrim (BS ByteString
x) = ByteString -> Str
BS (ByteString -> Str) -> ByteString -> Str
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.spanEnd Char -> Bool
isSpace (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS.dropWhile Char -> Bool
isSpace ByteString
x
strTrim (LBS ByteString
x) = ByteString -> Str
LBS (ByteString -> Str) -> ByteString -> Str
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
trimEnd (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
LBS.dropWhile Char -> Bool
isSpace ByteString
x
    where
        trimEnd :: ByteString -> ByteString
trimEnd ByteString
x = case ByteString -> Maybe (Char, ByteString)
LBS.uncons ByteString
x of
            Just (Char
c, ByteString
x2) | Char -> Bool
isSpace Char
c -> ByteString -> ByteString
trimEnd ByteString
x2
            Maybe (Char, ByteString)
_ -> ByteString
x
strTrim Str
Unit = Str
Unit


data Result
    = ResultStdout Str
    | ResultStderr Str
    | ResultStdouterr Str
    | ResultCode ExitCode
    | ResultTime Double
    | ResultLine String
    | ResultProcess PID
    | ResultFSATrace [FSATrace FilePath]
    | ResultFSATraceBS [FSATrace BS.ByteString]
      deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq,Int -> Result -> String -> String
[Result] -> String -> String
Result -> String
(Int -> Result -> String -> String)
-> (Result -> String)
-> ([Result] -> String -> String)
-> Show Result
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Result] -> String -> String
$cshowList :: [Result] -> String -> String
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> String -> String
$cshowsPrec :: Int -> Result -> String -> String
Show)

data PID = PID0 | PID ProcessHandle
instance Eq PID where PID
_ == :: PID -> PID -> Bool
== PID
_ = Bool
True
instance Show PID where show :: PID -> String
show PID
PID0 = String
"PID0"; show PID
_ = String
"PID"

data Params = Params
    {Params -> String
funcName :: String
    ,Params -> [CmdOption]
opts :: [CmdOption]
    ,Params -> [Result]
results :: [Result]
    ,Params -> String
prog :: String
    ,Params -> [String]
args :: [String]
    } deriving Int -> Params -> String -> String
[Params] -> String -> String
Params -> String
(Int -> Params -> String -> String)
-> (Params -> String)
-> ([Params] -> String -> String)
-> Show Params
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Params] -> String -> String
$cshowList :: [Params] -> String -> String
show :: Params -> String
$cshow :: Params -> String
showsPrec :: Int -> Params -> String -> String
$cshowsPrec :: Int -> Params -> String -> String
Show

class MonadIO m => MonadTempDir m where
    runWithTempDir :: (FilePath -> m a) -> m a
    runWithTempFile :: (FilePath -> m a) -> m a
instance MonadTempDir IO where
    runWithTempDir :: (String -> IO a) -> IO a
runWithTempDir = (String -> IO a) -> IO a
forall a. (String -> IO a) -> IO a
IO.withTempDir
    runWithTempFile :: (String -> IO a) -> IO a
runWithTempFile = (String -> IO a) -> IO a
forall a. (String -> IO a) -> IO a
IO.withTempFile
instance MonadTempDir Action where
    runWithTempDir :: (String -> Action a) -> Action a
runWithTempDir = (String -> Action a) -> Action a
forall a. (String -> Action a) -> Action a
withTempDir
    runWithTempFile :: (String -> Action a) -> Action a
runWithTempFile = (String -> Action a) -> Action a
forall a. (String -> Action a) -> Action a
withTempFile

---------------------------------------------------------------------
-- DEAL WITH Shell

removeOptionShell
    :: MonadTempDir m
    => Params -- ^ Given the parameter
    -> (Params -> m a) -- ^ Call with the revised params, program name and command line
    -> m a
removeOptionShell :: Params -> (Params -> m a) -> m a
removeOptionShell params :: Params
params@Params{String
[String]
[CmdOption]
[Result]
args :: [String]
prog :: String
results :: [Result]
opts :: [CmdOption]
funcName :: String
args :: Params -> [String]
prog :: Params -> String
results :: Params -> [Result]
opts :: Params -> [CmdOption]
funcName :: Params -> String
..} Params -> m a
call
    | CmdOption
Shell CmdOption -> [CmdOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CmdOption]
opts = do
        -- put our UserCommand first, as the last one wins, and ours is lowest priority
        let userCmdline :: String
userCmdline = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
prog String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
        Params
params <- Params -> m Params
forall (f :: * -> *) a. Applicative f => a -> f a
pure Params
params{opts :: [CmdOption]
opts = String -> CmdOption
UserCommand String
userCmdline CmdOption -> [CmdOption] -> [CmdOption]
forall a. a -> [a] -> [a]
: (CmdOption -> Bool) -> [CmdOption] -> [CmdOption]
forall a. (a -> Bool) -> [a] -> [a]
filter (CmdOption -> CmdOption -> Bool
forall a. Eq a => a -> a -> Bool
/= CmdOption
Shell) [CmdOption]
opts}

        String
prog <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ if Params -> Bool
isFSATrace Params
params then String -> IO String
copyFSABinary String
prog else String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
prog
        let realCmdline :: String
realCmdline = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
prog String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
        if Bool -> Bool
not Bool
isWindows then
            Params -> m a
call Params
params{prog :: String
prog = String
"/bin/sh", args :: [String]
args = [String
"-c",String
realCmdline]}
        else
            -- On Windows the Haskell behaviour isn't that clean and is very fragile, so we try and do better.
            (String -> m a) -> m a
forall (m :: * -> *) a. MonadTempDir m => (String -> m a) -> m a
runWithTempDir ((String -> m a) -> m a) -> (String -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
                let file :: String
file = String
dir String -> String -> String
</> String
"s.bat"
                String -> String -> m ()
forall (m :: * -> *).
(MonadIO m, Partial) =>
String -> String -> m ()
writeFile' String
file String
realCmdline
                Params -> m a
call Params
params{prog :: String
prog = String
"cmd.exe", args :: [String]
args = [String
"/d/q/c",String
file]}
    | Bool
otherwise = Params -> m a
call Params
params


---------------------------------------------------------------------
-- DEAL WITH FSATrace

isFSATrace :: Params -> Bool
isFSATrace :: Params -> Bool
isFSATrace Params{String
[String]
[CmdOption]
[Result]
args :: [String]
prog :: String
results :: [Result]
opts :: [CmdOption]
funcName :: String
args :: Params -> [String]
prog :: Params -> String
results :: Params -> [Result]
opts :: Params -> [CmdOption]
funcName :: Params -> String
..} = (Result -> Bool) -> [Result] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Result -> Bool
isResultFSATrace  [Result]
results Bool -> Bool -> Bool
|| (CmdOption -> Bool) -> [CmdOption] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CmdOption -> Bool
isFSAOptions [CmdOption]
opts

-- Mac disables tracing on system binaries, so we copy them over, yurk
copyFSABinary :: FilePath -> IO FilePath
copyFSABinary :: String -> IO String
copyFSABinary String
prog
    | Bool -> Bool
not Bool
isMac = String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
prog
    | Bool
otherwise = do
        Maybe String
progFull <- String -> IO (Maybe String)
findExecutable String
prog
        case Maybe String
progFull of
            Just String
x | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x) [String
"/bin/",String
"/usr/",String
"/sbin/"] -> do
                -- The file is one of the ones we can't trace, so we make a copy of it in $TMP and run that
                -- We deliberately don't clean up this directory, since otherwise we spend all our time copying binaries over
                String
tmpdir <- IO String
getTemporaryDirectory
                let fake :: String
fake = String
tmpdir String -> String -> String
</> String
"fsatrace-fakes" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x -- x is absolute, so must use ++
                IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> IO Bool
doesFileExist String
fake) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    String -> IO ()
createDirectoryRecursive (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
fake
                    String -> String -> IO ()
copyFile String
x String
fake
                String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
fake
            Maybe String
_ -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
prog

removeOptionFSATrace
    :: MonadTempDir m
    => Params -- ^ Given the parameter
    -> (Params -> m [Result]) -- ^ Call with the revised params, program name and command line
    -> m [Result]
removeOptionFSATrace :: Params -> (Params -> m [Result]) -> m [Result]
removeOptionFSATrace params :: Params
params@Params{String
[String]
[CmdOption]
[Result]
args :: [String]
prog :: String
results :: [Result]
opts :: [CmdOption]
funcName :: String
args :: Params -> [String]
prog :: Params -> String
results :: Params -> [Result]
opts :: Params -> [CmdOption]
funcName :: Params -> String
..} Params -> m [Result]
call
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Params -> Bool
isFSATrace Params
params = Params -> m [Result]
call Params
params
    | PID -> Result
ResultProcess PID
PID0 Result -> [Result] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Result]
results =
        -- This is a bad state to get into, you could technically just ignore the tracing, but that's a bit dangerous
        IO [Result] -> m [Result]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Result] -> m [Result]) -> IO [Result] -> m [Result]
forall a b. (a -> b) -> a -> b
$ String -> IO [Result]
forall a. Partial => String -> IO a
errorIO String
"Asyncronous process execution combined with FSATrace is not support"
    | Bool
otherwise = (String -> m [Result]) -> m [Result]
forall (m :: * -> *) a. MonadTempDir m => (String -> m a) -> m a
runWithTempFile ((String -> m [Result]) -> m [Result])
-> (String -> m [Result]) -> m [Result]
forall a b. (a -> b) -> a -> b
$ \String
file -> do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
file String
"" -- ensures even if we fail before fsatrace opens the file, we can still read it
        Params
params <- IO Params -> m Params
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Params -> m Params) -> IO Params -> m Params
forall a b. (a -> b) -> a -> b
$ String -> Params -> IO Params
fsaParams String
file Params
params
        [Result]
res <- Params -> m [Result]
call Params
params{opts :: [CmdOption]
opts = String -> CmdOption
UserCommand (String -> [String] -> String
showCommandForUser2 String
prog [String]
args) CmdOption -> [CmdOption] -> [CmdOption]
forall a. a -> [a] -> [a]
: (CmdOption -> Bool) -> [CmdOption] -> [CmdOption]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CmdOption -> Bool) -> CmdOption -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdOption -> Bool
isFSAOptions) [CmdOption]
opts}
        [FSATrace ByteString]
fsaResBS <- IO [FSATrace ByteString] -> m [FSATrace ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FSATrace ByteString] -> m [FSATrace ByteString])
-> IO [FSATrace ByteString] -> m [FSATrace ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [FSATrace ByteString]
parseFSA (ByteString -> [FSATrace ByteString])
-> IO ByteString -> IO [FSATrace ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
file
        let fsaRes :: [FSATrace String]
fsaRes = (FSATrace ByteString -> FSATrace String)
-> [FSATrace ByteString] -> [FSATrace String]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> String) -> FSATrace ByteString -> FSATrace String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
UTF8.toString) [FSATrace ByteString]
fsaResBS
        [Result] -> m [Result]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Result] -> m [Result]) -> [Result] -> m [Result]
forall a b. (a -> b) -> a -> b
$ ((Result -> Result) -> [Result] -> [Result])
-> [Result] -> (Result -> Result) -> [Result]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Result -> Result) -> [Result] -> [Result]
forall a b. (a -> b) -> [a] -> [b]
map [Result]
res ((Result -> Result) -> [Result]) -> (Result -> Result) -> [Result]
forall a b. (a -> b) -> a -> b
$ \case
            ResultFSATrace [] -> [FSATrace String] -> Result
ResultFSATrace [FSATrace String]
fsaRes
            ResultFSATraceBS [] -> [FSATrace ByteString] -> Result
ResultFSATraceBS [FSATrace ByteString]
fsaResBS
            Result
x -> Result
x
    where
        fsaFlags :: String
fsaFlags = String -> [String] -> String
forall a. a -> [a] -> a
lastDef String
"rwmdqt" [String
x | FSAOptions String
x <- [CmdOption]
opts]

        fsaParams :: String -> Params -> IO Params
fsaParams String
file Params{String
[String]
[CmdOption]
[Result]
args :: [String]
prog :: String
results :: [Result]
opts :: [CmdOption]
funcName :: String
args :: Params -> [String]
prog :: Params -> String
results :: Params -> [Result]
opts :: Params -> [CmdOption]
funcName :: Params -> String
..} = do
            String
prog <- String -> IO String
copyFSABinary String
prog
            Params -> IO Params
forall (f :: * -> *) a. Applicative f => a -> f a
pure Params
params{prog :: String
prog = String
"fsatrace", args :: [String]
args = String
fsaFlags String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
file String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
prog String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args }


isFSAOptions :: CmdOption -> Bool
isFSAOptions FSAOptions{} = Bool
True
isFSAOptions CmdOption
_ = Bool
False

isResultFSATrace :: Result -> Bool
isResultFSATrace ResultFSATrace{} = Bool
True
isResultFSATrace ResultFSATraceBS{} = Bool
True
isResultFSATrace Result
_ = Bool
False

addFSAOptions :: String -> [CmdOption] -> [CmdOption]
addFSAOptions :: String -> [CmdOption] -> [CmdOption]
addFSAOptions String
x [CmdOption]
opts | (CmdOption -> Bool) -> [CmdOption] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CmdOption -> Bool
isFSAOptions [CmdOption]
opts = (CmdOption -> CmdOption) -> [CmdOption] -> [CmdOption]
forall a b. (a -> b) -> [a] -> [b]
map CmdOption -> CmdOption
f [CmdOption]
opts
    where f :: CmdOption -> CmdOption
f (FSAOptions String
y) = String -> CmdOption
FSAOptions (String -> CmdOption) -> String -> CmdOption
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Ord a => [a] -> [a]
nubOrd (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
          f CmdOption
x = CmdOption
x
addFSAOptions String
x [CmdOption]
opts = String -> CmdOption
FSAOptions String
x CmdOption -> [CmdOption] -> [CmdOption]
forall a. a -> [a] -> [a]
: [CmdOption]
opts


-- | The results produced by @fsatrace@. All files will be absolute paths.
--   You can get the results for a 'cmd' by requesting a value of type
--   @['FSATrace']@.
data FSATrace a
    = -- | Writing to a file
      FSAWrite a
    | -- | Reading from a file
      FSARead a
    | -- | Deleting a file
      FSADelete a
    | -- | Moving, arguments destination, then source
      FSAMove a a
    | -- | Querying\/stat on a file
      FSAQuery a
    | -- | Touching a file
      FSATouch a
      deriving (Int -> FSATrace a -> String -> String
[FSATrace a] -> String -> String
FSATrace a -> String
(Int -> FSATrace a -> String -> String)
-> (FSATrace a -> String)
-> ([FSATrace a] -> String -> String)
-> Show (FSATrace a)
forall a. Show a => Int -> FSATrace a -> String -> String
forall a. Show a => [FSATrace a] -> String -> String
forall a. Show a => FSATrace a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FSATrace a] -> String -> String
$cshowList :: forall a. Show a => [FSATrace a] -> String -> String
show :: FSATrace a -> String
$cshow :: forall a. Show a => FSATrace a -> String
showsPrec :: Int -> FSATrace a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> FSATrace a -> String -> String
Show,FSATrace a -> FSATrace a -> Bool
(FSATrace a -> FSATrace a -> Bool)
-> (FSATrace a -> FSATrace a -> Bool) -> Eq (FSATrace a)
forall a. Eq a => FSATrace a -> FSATrace a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FSATrace a -> FSATrace a -> Bool
$c/= :: forall a. Eq a => FSATrace a -> FSATrace a -> Bool
== :: FSATrace a -> FSATrace a -> Bool
$c== :: forall a. Eq a => FSATrace a -> FSATrace a -> Bool
Eq,Eq (FSATrace a)
Eq (FSATrace a)
-> (FSATrace a -> FSATrace a -> Ordering)
-> (FSATrace a -> FSATrace a -> Bool)
-> (FSATrace a -> FSATrace a -> Bool)
-> (FSATrace a -> FSATrace a -> Bool)
-> (FSATrace a -> FSATrace a -> Bool)
-> (FSATrace a -> FSATrace a -> FSATrace a)
-> (FSATrace a -> FSATrace a -> FSATrace a)
-> Ord (FSATrace a)
FSATrace a -> FSATrace a -> Bool
FSATrace a -> FSATrace a -> Ordering
FSATrace a -> FSATrace a -> FSATrace a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (FSATrace a)
forall a. Ord a => FSATrace a -> FSATrace a -> Bool
forall a. Ord a => FSATrace a -> FSATrace a -> Ordering
forall a. Ord a => FSATrace a -> FSATrace a -> FSATrace a
min :: FSATrace a -> FSATrace a -> FSATrace a
$cmin :: forall a. Ord a => FSATrace a -> FSATrace a -> FSATrace a
max :: FSATrace a -> FSATrace a -> FSATrace a
$cmax :: forall a. Ord a => FSATrace a -> FSATrace a -> FSATrace a
>= :: FSATrace a -> FSATrace a -> Bool
$c>= :: forall a. Ord a => FSATrace a -> FSATrace a -> Bool
> :: FSATrace a -> FSATrace a -> Bool
$c> :: forall a. Ord a => FSATrace a -> FSATrace a -> Bool
<= :: FSATrace a -> FSATrace a -> Bool
$c<= :: forall a. Ord a => FSATrace a -> FSATrace a -> Bool
< :: FSATrace a -> FSATrace a -> Bool
$c< :: forall a. Ord a => FSATrace a -> FSATrace a -> Bool
compare :: FSATrace a -> FSATrace a -> Ordering
$ccompare :: forall a. Ord a => FSATrace a -> FSATrace a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (FSATrace a)
Ord,Typeable (FSATrace a)
DataType
Constr
Typeable (FSATrace a)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> FSATrace a -> c (FSATrace a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (FSATrace a))
-> (FSATrace a -> Constr)
-> (FSATrace a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (FSATrace a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (FSATrace a)))
-> ((forall b. Data b => b -> b) -> FSATrace a -> FSATrace a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> FSATrace a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> FSATrace a -> r)
-> (forall u. (forall d. Data d => d -> u) -> FSATrace a -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> FSATrace a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a))
-> Data (FSATrace a)
FSATrace a -> DataType
FSATrace a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (FSATrace a))
(forall b. Data b => b -> b) -> FSATrace a -> FSATrace a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FSATrace a -> c (FSATrace a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FSATrace a)
forall a. Data a => Typeable (FSATrace a)
forall a. Data a => FSATrace a -> DataType
forall a. Data a => FSATrace a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> FSATrace a -> FSATrace a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> FSATrace a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> FSATrace a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FSATrace a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FSATrace a -> c (FSATrace a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (FSATrace a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (FSATrace a))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> FSATrace a -> u
forall u. (forall d. Data d => d -> u) -> FSATrace a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FSATrace a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FSATrace a -> c (FSATrace a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (FSATrace a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (FSATrace a))
$cFSATouch :: Constr
$cFSAQuery :: Constr
$cFSAMove :: Constr
$cFSADelete :: Constr
$cFSARead :: Constr
$cFSAWrite :: Constr
$tFSATrace :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
gmapMp :: (forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
gmapM :: (forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> FSATrace a -> m (FSATrace a)
gmapQi :: Int -> (forall d. Data d => d -> u) -> FSATrace a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> FSATrace a -> u
gmapQ :: (forall d. Data d => d -> u) -> FSATrace a -> [u]
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> FSATrace a -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FSATrace a -> r
gmapT :: (forall b. Data b => b -> b) -> FSATrace a -> FSATrace a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> FSATrace a -> FSATrace a
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (FSATrace a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (FSATrace a))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (FSATrace a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (FSATrace a))
dataTypeOf :: FSATrace a -> DataType
$cdataTypeOf :: forall a. Data a => FSATrace a -> DataType
toConstr :: FSATrace a -> Constr
$ctoConstr :: forall a. Data a => FSATrace a -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FSATrace a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FSATrace a)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FSATrace a -> c (FSATrace a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FSATrace a -> c (FSATrace a)
$cp1Data :: forall a. Data a => Typeable (FSATrace a)
Data,Typeable,a -> FSATrace b -> FSATrace a
(a -> b) -> FSATrace a -> FSATrace b
(forall a b. (a -> b) -> FSATrace a -> FSATrace b)
-> (forall a b. a -> FSATrace b -> FSATrace a) -> Functor FSATrace
forall a b. a -> FSATrace b -> FSATrace a
forall a b. (a -> b) -> FSATrace a -> FSATrace b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FSATrace b -> FSATrace a
$c<$ :: forall a b. a -> FSATrace b -> FSATrace a
fmap :: (a -> b) -> FSATrace a -> FSATrace b
$cfmap :: forall a b. (a -> b) -> FSATrace a -> FSATrace b
Functor)


-- | Parse the 'FSATrace' entries, ignoring anything you don't understand.
parseFSA :: BS.ByteString -> [FSATrace BS.ByteString]
parseFSA :: ByteString -> [FSATrace ByteString]
parseFSA = (ByteString -> Maybe (FSATrace ByteString))
-> [ByteString] -> [FSATrace ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ByteString -> Maybe (FSATrace ByteString)
f (ByteString -> Maybe (FSATrace ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> Maybe (FSATrace ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropR) ([ByteString] -> [FSATrace ByteString])
-> (ByteString -> [ByteString])
-> ByteString
-> [FSATrace ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.lines
    where
        -- deal with CRLF on Windows
        dropR :: ByteString -> ByteString
dropR ByteString
x = case ByteString -> Maybe (ByteString, Char)
BS.unsnoc ByteString
x of
            Just (ByteString
x, Char
'\r') -> ByteString
x
            Maybe (ByteString, Char)
_ -> ByteString
x

        f :: ByteString -> Maybe (FSATrace ByteString)
f ByteString
x
            | Just (Char
k, ByteString
x) <- ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
x
            , Just (Char
'|', ByteString
x) <- ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
x =
                case Char
k of
                    Char
'w' -> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a. a -> Maybe a
Just (FSATrace ByteString -> Maybe (FSATrace ByteString))
-> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> FSATrace ByteString
forall a. a -> FSATrace a
FSAWrite ByteString
x
                    Char
'r' -> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a. a -> Maybe a
Just (FSATrace ByteString -> Maybe (FSATrace ByteString))
-> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> FSATrace ByteString
forall a. a -> FSATrace a
FSARead  ByteString
x
                    Char
'd' -> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a. a -> Maybe a
Just (FSATrace ByteString -> Maybe (FSATrace ByteString))
-> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> FSATrace ByteString
forall a. a -> FSATrace a
FSADelete ByteString
x
                    Char
'm' | (ByteString
xs, ByteString
ys) <- (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'|') ByteString
x, Just (Char
'|',ByteString
ys) <- ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
ys ->
                        FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a. a -> Maybe a
Just (FSATrace ByteString -> Maybe (FSATrace ByteString))
-> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> FSATrace ByteString
forall a. a -> a -> FSATrace a
FSAMove ByteString
xs ByteString
ys
                    Char
'q' -> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a. a -> Maybe a
Just (FSATrace ByteString -> Maybe (FSATrace ByteString))
-> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> FSATrace ByteString
forall a. a -> FSATrace a
FSAQuery ByteString
x
                    Char
't' -> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a. a -> Maybe a
Just (FSATrace ByteString -> Maybe (FSATrace ByteString))
-> FSATrace ByteString -> Maybe (FSATrace ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> FSATrace ByteString
forall a. a -> FSATrace a
FSATouch ByteString
x
                    Char
_ -> Maybe (FSATrace ByteString)
forall a. Maybe a
Nothing
            | Bool
otherwise = Maybe (FSATrace ByteString)
forall a. Maybe a
Nothing


---------------------------------------------------------------------
-- ACTION EXPLICIT OPERATION

-- | Given explicit operations, apply the Action ones, like skip/trace/track/autodep
commandExplicitAction :: Partial => Params -> Action [Result]
commandExplicitAction :: Params -> Action [Result]
commandExplicitAction Params
oparams = do
    ShakeOptions{[CmdOption]
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeCommandOptions :: [CmdOption]
shakeCommandOptions,Bool
shakeRunCommands :: ShakeOptions -> Bool
shakeRunCommands :: Bool
shakeRunCommands,Maybe Lint
shakeLint :: ShakeOptions -> Maybe Lint
shakeLint :: Maybe Lint
shakeLint,[String]
shakeLintInside :: ShakeOptions -> [String]
shakeLintInside :: [String]
shakeLintInside} <- Action ShakeOptions
getShakeOptions
    params :: Params
params@Params{String
[String]
[CmdOption]
[Result]
args :: [String]
prog :: String
results :: [Result]
opts :: [CmdOption]
funcName :: String
args :: Params -> [String]
prog :: Params -> String
results :: Params -> [Result]
opts :: Params -> [CmdOption]
funcName :: Params -> String
..}<- Params -> Action Params
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Params -> Action Params) -> Params -> Action Params
forall a b. (a -> b) -> a -> b
$ Params
oparams{opts :: [CmdOption]
opts = [CmdOption]
shakeCommandOptions [CmdOption] -> [CmdOption] -> [CmdOption]
forall a. [a] -> [a] -> [a]
++ Params -> [CmdOption]
opts Params
oparams}

    let skipper :: Action [Result] -> Action [Result]
skipper Action [Result]
act = if [Result] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Result]
results Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
shakeRunCommands then [Result] -> Action [Result]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else Action [Result]
act

    let verboser :: Action [Result] -> Action [Result]
verboser Action [Result]
act = do
            let cwd :: Maybe String
cwd = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String
x | Cwd String
x <- [CmdOption]
opts]
            String -> Action ()
putVerbose (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$
                String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
x -> String
"cd " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; ") Maybe String
cwd String -> String -> String
forall a. [a] -> [a] -> [a]
++
                [String] -> String
forall a. [a] -> a
last (String -> [String] -> String
showCommandForUser2 String
prog [String]
args String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
x | UserCommand String
x <- [CmdOption]
opts])
            Verbosity
verb <- Action Verbosity
getVerbosity
            -- run quietly to suppress the tracer (don't want to print twice)
            (if Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbose then Action [Result] -> Action [Result]
forall a. Action a -> Action a
quietly else Action [Result] -> Action [Result]
forall a. a -> a
id) Action [Result]
act

    let tracer :: IO [Result] -> Action [Result]
tracer IO [Result]
act = do
            -- note: use the oparams - find a good tracing before munging it for shell stuff
            let msg :: String
msg = String -> [String] -> String
forall a. a -> [a] -> a
lastDef (Params -> String
defaultTraced Params
oparams) [String
x | Traced String
x <- [CmdOption]
opts]
            if String
msg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then IO [Result] -> Action [Result]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Result]
act else String -> IO [Result] -> Action [Result]
forall a. String -> IO a -> Action a
traced String
msg IO [Result]
act

    let async :: Bool
async = PID -> Result
ResultProcess PID
PID0 Result -> [Result] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Result]
results
    let tracker :: (Params -> Action [Result]) -> Action [Result]
tracker Params -> Action [Result]
act
            | CmdOption
AutoDeps CmdOption -> [CmdOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CmdOption]
opts = if Bool
async then IO [Result] -> Action [Result]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Result] -> Action [Result]) -> IO [Result] -> Action [Result]
forall a b. (a -> b) -> a -> b
$ String -> IO [Result]
forall a. Partial => String -> IO a
errorIO String
"Can't use AutoDeps and asyncronous execution" else (Params -> Action [Result]) -> Action [Result]
autodeps Params -> Action [Result]
act
            | Maybe Lint
shakeLint Maybe Lint -> Maybe Lint -> Bool
forall a. Eq a => a -> a -> Bool
== Lint -> Maybe Lint
forall a. a -> Maybe a
Just Lint
LintFSATrace Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
async = (Params -> Action [Result]) -> Action [Result]
fsalint Params -> Action [Result]
act
            | Bool
otherwise = Params -> Action [Result]
act Params
params

        autodeps :: (Params -> Action [Result]) -> Action [Result]
autodeps Params -> Action [Result]
act = do
            ResultFSATrace [FSATrace String]
pxs : [Result]
res <- Params -> Action [Result]
act Params
params{opts :: [CmdOption]
opts = String -> [CmdOption] -> [CmdOption]
addFSAOptions String
"rwm" [CmdOption]
opts, results :: [Result]
results = [FSATrace String] -> Result
ResultFSATrace [] Result -> [Result] -> [Result]
forall a. a -> [a] -> [a]
: [Result]
results}
            let written :: HashSet String
written = [String] -> HashSet String
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([String] -> HashSet String) -> [String] -> HashSet String
forall a b. (a -> b) -> a -> b
$ [String
x | FSAMove String
x String
_ <- [FSATrace String]
pxs] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
x | FSAWrite String
x <- [FSATrace String]
pxs]
            -- If something both reads and writes to a file, it isn't eligible to be an autodeps
            [String]
xs <- IO [String] -> Action [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Action [String]) -> IO [String] -> Action [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String
x | FSARead String
x <- [FSATrace String]
pxs, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
x String -> HashSet String -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet String
written]
            String
cwd <- IO String -> Action String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
            [String]
temp <- String -> [String] -> Action [String]
fixPaths String
cwd [String]
xs
            Action () -> Action ()
forall a. Action a -> Action a
unsafeAllowApply (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ Partial => [String] -> Action ()
[String] -> Action ()
need [String]
temp
            [Result] -> Action [Result]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Result]
res

        fixPaths :: String -> [String] -> Action [String]
fixPaths String
cwd [String]
xs = IO [String] -> Action [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Action [String]) -> IO [String] -> Action [String]
forall a b. (a -> b) -> a -> b
$ do
            [String]
xs<- [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
toStandard [String]
xs
            [String]
xs<- [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
x -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x) [String]
shakeLintInside) [String]
xs
            (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
x -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
x (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO (Maybe String)
makeRelativeEx String
cwd String
x) [String]
xs

        fsalint :: (Params -> Action [Result]) -> Action [Result]
fsalint Params -> Action [Result]
act = do
            ResultFSATrace [FSATrace String]
xs : [Result]
res <- Params -> Action [Result]
act Params
params{opts :: [CmdOption]
opts = String -> [CmdOption] -> [CmdOption]
addFSAOptions String
"rwm" [CmdOption]
opts, results :: [Result]
results = [FSATrace String] -> Result
ResultFSATrace [] Result -> [Result] -> [Result]
forall a. a -> [a] -> [a]
: [Result]
results}
            let reader :: FSATrace a -> Maybe a
reader (FSARead a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x; reader FSATrace a
_ = Maybe a
forall a. Maybe a
Nothing
                writer :: FSATrace a -> Maybe a
writer (FSAWrite a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x; writer (FSAMove a
x a
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x; writer FSATrace a
_ = Maybe a
forall a. Maybe a
Nothing
                existing :: (a -> Maybe String) -> [a] -> m [String]
existing a -> Maybe String
f = IO [String] -> m [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String])
-> ([a] -> IO [String]) -> [a] -> m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist ([String] -> IO [String])
-> ([a] -> [String]) -> [a] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> ([a] -> [String]) -> [a] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe String) -> [a] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe String
f
            String
cwd <- IO String -> Action String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
            [String] -> Action ()
trackRead  ([String] -> Action ()) -> Action [String] -> Action ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [String] -> Action [String]
fixPaths String
cwd ([String] -> Action [String]) -> Action [String] -> Action [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FSATrace String -> Maybe String)
-> [FSATrace String] -> Action [String]
forall (m :: * -> *) a.
MonadIO m =>
(a -> Maybe String) -> [a] -> m [String]
existing FSATrace String -> Maybe String
forall a. FSATrace a -> Maybe a
reader [FSATrace String]
xs
            [String] -> Action ()
trackWrite ([String] -> Action ()) -> Action [String] -> Action ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [String] -> Action [String]
fixPaths String
cwd ([String] -> Action [String]) -> Action [String] -> Action [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FSATrace String -> Maybe String)
-> [FSATrace String] -> Action [String]
forall (m :: * -> *) a.
MonadIO m =>
(a -> Maybe String) -> [a] -> m [String]
existing FSATrace String -> Maybe String
forall a. FSATrace a -> Maybe a
writer [FSATrace String]
xs
            [Result] -> Action [Result]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Result]
res

    Action [Result] -> Action [Result]
skipper (Action [Result] -> Action [Result])
-> Action [Result] -> Action [Result]
forall a b. (a -> b) -> a -> b
$ (Params -> Action [Result]) -> Action [Result]
tracker ((Params -> Action [Result]) -> Action [Result])
-> (Params -> Action [Result]) -> Action [Result]
forall a b. (a -> b) -> a -> b
$ \Params
params -> Action [Result] -> Action [Result]
verboser (Action [Result] -> Action [Result])
-> Action [Result] -> Action [Result]
forall a b. (a -> b) -> a -> b
$ IO [Result] -> Action [Result]
tracer (IO [Result] -> Action [Result]) -> IO [Result] -> Action [Result]
forall a b. (a -> b) -> a -> b
$ Partial => Params -> IO [Result]
Params -> IO [Result]
commandExplicitIO Params
params


defaultTraced :: Params -> String
defaultTraced :: Params -> String
defaultTraced Params{String
[String]
[CmdOption]
[Result]
args :: [String]
prog :: String
results :: [Result]
opts :: [CmdOption]
funcName :: String
args :: Params -> [String]
prog :: Params -> String
results :: Params -> [Result]
opts :: Params -> [CmdOption]
funcName :: Params -> String
..} = String -> String
takeBaseName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ if CmdOption
Shell CmdOption -> [CmdOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CmdOption]
opts then (String, String) -> String
forall a b. (a, b) -> a
fst (String -> (String, String)
word1 String
prog) else String
prog


---------------------------------------------------------------------
-- IO EXPLICIT OPERATION

-- | Given a very explicit set of CmdOption, translate them to a General.Process structure
commandExplicitIO :: Partial => Params -> IO [Result]
commandExplicitIO :: Params -> IO [Result]
commandExplicitIO Params
params = Params -> (Params -> IO [Result]) -> IO [Result]
forall (m :: * -> *) a.
MonadTempDir m =>
Params -> (Params -> m a) -> m a
removeOptionShell Params
params ((Params -> IO [Result]) -> IO [Result])
-> (Params -> IO [Result]) -> IO [Result]
forall a b. (a -> b) -> a -> b
$ \Params
params -> Params -> (Params -> IO [Result]) -> IO [Result]
forall (m :: * -> *).
MonadTempDir m =>
Params -> (Params -> m [Result]) -> m [Result]
removeOptionFSATrace Params
params ((Params -> IO [Result]) -> IO [Result])
-> (Params -> IO [Result]) -> IO [Result]
forall a b. (a -> b) -> a -> b
$ \Params{String
[String]
[CmdOption]
[Result]
args :: [String]
prog :: String
results :: [Result]
opts :: [CmdOption]
funcName :: String
args :: Params -> [String]
prog :: Params -> String
results :: Params -> [Result]
opts :: Params -> [CmdOption]
funcName :: Params -> String
..} -> do
    let (Bool
grabStdout, Bool
grabStderr) = ([Bool] -> Bool) -> ([Bool], [Bool]) -> (Bool, Bool)
forall a b. (a -> b) -> (a, a) -> (b, b)
both [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (([Bool], [Bool]) -> (Bool, Bool))
-> ([Bool], [Bool]) -> (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ [(Bool, Bool)] -> ([Bool], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Bool, Bool)] -> ([Bool], [Bool]))
-> [(Bool, Bool)] -> ([Bool], [Bool])
forall a b. (a -> b) -> a -> b
$ ((Result -> (Bool, Bool)) -> [Result] -> [(Bool, Bool)])
-> [Result] -> (Result -> (Bool, Bool)) -> [(Bool, Bool)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Result -> (Bool, Bool)) -> [Result] -> [(Bool, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map [Result]
results ((Result -> (Bool, Bool)) -> [(Bool, Bool)])
-> (Result -> (Bool, Bool)) -> [(Bool, Bool)]
forall a b. (a -> b) -> a -> b
$ \case
            ResultStdout{} -> (Bool
True, Bool
False)
            ResultStderr{} -> (Bool
False, Bool
True)
            ResultStdouterr{} -> (Bool
True, Bool
True)
            Result
_ -> (Bool
False, Bool
False)

    Maybe [(String, String)]
optEnv <- [CmdOption] -> IO (Maybe [(String, String)])
resolveEnv [CmdOption]
opts
    let optCwd :: Maybe String
optCwd = [String] -> Maybe String
mergeCwd [String
x | Cwd String
x <- [CmdOption]
opts]
    let optStdin :: [Source]
optStdin = ((CmdOption -> Maybe Source) -> [CmdOption] -> [Source])
-> [CmdOption] -> (CmdOption -> Maybe Source) -> [Source]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CmdOption -> Maybe Source) -> [CmdOption] -> [Source]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [CmdOption]
opts ((CmdOption -> Maybe Source) -> [Source])
-> (CmdOption -> Maybe Source) -> [Source]
forall a b. (a -> b) -> a -> b
$ \case
            Stdin String
x -> Source -> Maybe Source
forall a. a -> Maybe a
Just (Source -> Maybe Source) -> Source -> Maybe Source
forall a b. (a -> b) -> a -> b
$ String -> Source
SrcString String
x
            StdinBS ByteString
x -> Source -> Maybe Source
forall a. a -> Maybe a
Just (Source -> Maybe Source) -> Source -> Maybe Source
forall a b. (a -> b) -> a -> b
$ ByteString -> Source
SrcBytes ByteString
x
            FileStdin String
x -> Source -> Maybe Source
forall a. a -> Maybe a
Just (Source -> Maybe Source) -> Source -> Maybe Source
forall a b. (a -> b) -> a -> b
$ String -> Source
SrcFile String
x
            CmdOption
InheritStdin -> Source -> Maybe Source
forall a. a -> Maybe a
Just Source
SrcInherit
            CmdOption
_ -> Maybe Source
forall a. Maybe a
Nothing
    let optBinary :: Bool
optBinary = CmdOption
BinaryPipes CmdOption -> [CmdOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CmdOption]
opts
    let optAsync :: Bool
optAsync = PID -> Result
ResultProcess PID
PID0 Result -> [Result] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Result]
results
    let optTimeout :: Maybe Double
optTimeout = [Double] -> Maybe Double
forall a. [a] -> Maybe a
listToMaybe ([Double] -> Maybe Double) -> [Double] -> Maybe Double
forall a b. (a -> b) -> a -> b
$ [Double] -> [Double]
forall a. [a] -> [a]
reverse [Double
x | Timeout Double
x <- [CmdOption]
opts]
    let optWithStdout :: Bool
optWithStdout = Bool -> [Bool] -> Bool
forall a. a -> [a] -> a
lastDef Bool
False [Bool
x | WithStdout Bool
x <- [CmdOption]
opts]
    let optWithStderr :: Bool
optWithStderr = Bool -> [Bool] -> Bool
forall a. a -> [a] -> a
lastDef Bool
True [Bool
x | WithStderr Bool
x <- [CmdOption]
opts]
    let optFileStdout :: [String]
optFileStdout = [String
x | FileStdout String
x <- [CmdOption]
opts]
    let optFileStderr :: [String]
optFileStderr = [String
x | FileStderr String
x <- [CmdOption]
opts]
    let optEchoStdout :: Bool
optEchoStdout = Bool -> [Bool] -> Bool
forall a. a -> [a] -> a
lastDef (Bool -> Bool
not Bool
grabStdout Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
optFileStdout) [Bool
x | EchoStdout Bool
x <- [CmdOption]
opts]
    let optEchoStderr :: Bool
optEchoStderr = Bool -> [Bool] -> Bool
forall a. a -> [a] -> a
lastDef (Bool -> Bool
not Bool
grabStderr Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
optFileStderr) [Bool
x | EchoStderr Bool
x <- [CmdOption]
opts]
    let optRealCommand :: String
optRealCommand = String -> [String] -> String
showCommandForUser2 String
prog [String]
args
    let optUserCommand :: String
optUserCommand = String -> [String] -> String
forall a. a -> [a] -> a
lastDef String
optRealCommand [String
x | UserCommand String
x <- [CmdOption]
opts]
    let optCloseFds :: Bool
optCloseFds = CmdOption
CloseFileHandles CmdOption -> [CmdOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CmdOption]
opts
    let optProcessGroup :: Bool
optProcessGroup = CmdOption
NoProcessGroup CmdOption -> [CmdOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CmdOption]
opts

    let bufLBS :: (ByteString -> Str) -> IO ([Destination], IO Str)
bufLBS ByteString -> Str
f = do ([Destination]
a,IO Str
b) <- Str -> IO ([Destination], IO Str)
buf (Str -> IO ([Destination], IO Str))
-> Str -> IO ([Destination], IO Str)
forall a b. (a -> b) -> a -> b
$ ByteString -> Str
LBS ByteString
LBS.empty; ([Destination], IO Str) -> IO ([Destination], IO Str)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Destination]
a, (\(LBS ByteString
x) -> ByteString -> Str
f ByteString
x) (Str -> Str) -> IO Str -> IO Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Str
b)
        buf :: Str -> IO ([Destination], IO Str)
buf Str{} | Bool
optBinary = (ByteString -> Str) -> IO ([Destination], IO Str)
bufLBS (String -> Str
Str (String -> Str) -> (ByteString -> String) -> ByteString -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
LBS.unpack)
        buf Str{} = do Buffer String
x <- IO (Buffer String)
forall a. IO (Buffer a)
newBuffer; ([Destination], IO Str) -> IO ([Destination], IO Str)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Buffer String -> Destination
DestString Buffer String
x | Bool -> Bool
not Bool
optAsync], String -> Str
Str (String -> Str) -> ([String] -> String) -> [String] -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> Str) -> IO [String] -> IO Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Buffer String -> IO [String]
forall a. Buffer a -> IO [a]
readBuffer Buffer String
x)
        buf LBS{} = do Buffer ByteString
x <- IO (Buffer ByteString)
forall a. IO (Buffer a)
newBuffer; ([Destination], IO Str) -> IO ([Destination], IO Str)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Buffer ByteString -> Destination
DestBytes Buffer ByteString
x | Bool -> Bool
not Bool
optAsync], ByteString -> Str
LBS (ByteString -> Str)
-> ([ByteString] -> ByteString) -> [ByteString] -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.fromChunks ([ByteString] -> Str) -> IO [ByteString] -> IO Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Buffer ByteString -> IO [ByteString]
forall a. Buffer a -> IO [a]
readBuffer Buffer ByteString
x)
        buf BS {} = (ByteString -> Str) -> IO ([Destination], IO Str)
bufLBS (ByteString -> Str
BS (ByteString -> Str)
-> (ByteString -> ByteString) -> ByteString -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.toChunks)
        buf Str
Unit  = ([Destination], IO Str) -> IO ([Destination], IO Str)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Str -> IO Str
forall (f :: * -> *) a. Applicative f => a -> f a
pure Str
Unit)
    ([[Destination]]
dStdout, [[Destination]]
dStderr, [Double -> ProcessHandle -> ExitCode -> IO Result]
resultBuild) :: ([[Destination]], [[Destination]], [Double -> ProcessHandle -> ExitCode -> IO Result]) <-
        ([([Destination], [Destination],
   Double -> ProcessHandle -> ExitCode -> IO Result)]
 -> ([[Destination]], [[Destination]],
     [Double -> ProcessHandle -> ExitCode -> IO Result]))
-> IO
     [([Destination], [Destination],
       Double -> ProcessHandle -> ExitCode -> IO Result)]
-> IO
     ([[Destination]], [[Destination]],
      [Double -> ProcessHandle -> ExitCode -> IO Result])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [([Destination], [Destination],
  Double -> ProcessHandle -> ExitCode -> IO Result)]
-> ([[Destination]], [[Destination]],
    [Double -> ProcessHandle -> ExitCode -> IO Result])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 (IO
   [([Destination], [Destination],
     Double -> ProcessHandle -> ExitCode -> IO Result)]
 -> IO
      ([[Destination]], [[Destination]],
       [Double -> ProcessHandle -> ExitCode -> IO Result]))
-> IO
     [([Destination], [Destination],
       Double -> ProcessHandle -> ExitCode -> IO Result)]
-> IO
     ([[Destination]], [[Destination]],
      [Double -> ProcessHandle -> ExitCode -> IO Result])
forall a b. (a -> b) -> a -> b
$ [Result]
-> (Result
    -> IO
         ([Destination], [Destination],
          Double -> ProcessHandle -> ExitCode -> IO Result))
-> IO
     [([Destination], [Destination],
       Double -> ProcessHandle -> ExitCode -> IO Result)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Result]
results ((Result
  -> IO
       ([Destination], [Destination],
        Double -> ProcessHandle -> ExitCode -> IO Result))
 -> IO
      [([Destination], [Destination],
        Double -> ProcessHandle -> ExitCode -> IO Result)])
-> (Result
    -> IO
         ([Destination], [Destination],
          Double -> ProcessHandle -> ExitCode -> IO Result))
-> IO
     [([Destination], [Destination],
       Double -> ProcessHandle -> ExitCode -> IO Result)]
forall a b. (a -> b) -> a -> b
$ \case
            ResultCode ExitCode
_ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \Double
_ ProcessHandle
_ ExitCode
ex -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ ExitCode -> Result
ResultCode ExitCode
ex)
            ResultTime Double
_ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \Double
dur ProcessHandle
_ ExitCode
_ -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Double -> Result
ResultTime Double
dur)
            ResultLine String
_ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \Double
_ ProcessHandle
_ ExitCode
_ -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
ResultLine String
optUserCommand)
            ResultProcess PID
_ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \Double
_ ProcessHandle
pid ExitCode
_ -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ PID -> Result
ResultProcess (PID -> Result) -> PID -> Result
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> PID
PID ProcessHandle
pid)
            ResultStdout    Str
s -> do ([Destination]
a,IO Str
b) <- Str -> IO ([Destination], IO Str)
buf Str
s; ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Destination]
a , [], \Double
_ ProcessHandle
_ ExitCode
_ -> (Str -> Result) -> IO Str -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Str -> Result
ResultStdout IO Str
b)
            ResultStderr    Str
s -> do ([Destination]
a,IO Str
b) <- Str -> IO ([Destination], IO Str)
buf Str
s; ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Destination]
a , \Double
_ ProcessHandle
_ ExitCode
_ -> (Str -> Result) -> IO Str -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Str -> Result
ResultStderr IO Str
b)
            ResultStdouterr Str
s -> do ([Destination]
a,IO Str
b) <- Str -> IO ([Destination], IO Str)
buf Str
s; ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Destination]
a , [Destination]
a , \Double
_ ProcessHandle
_ ExitCode
_ -> (Str -> Result) -> IO Str -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Str -> Result
ResultStdouterr IO Str
b)
            ResultFSATrace [FSATrace String]
_ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \Double
_ ProcessHandle
_ ExitCode
_ -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ [FSATrace String] -> Result
ResultFSATrace []) -- filled in elsewhere
            ResultFSATraceBS [FSATrace ByteString]
_ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \Double
_ ProcessHandle
_ ExitCode
_ -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ [FSATrace ByteString] -> Result
ResultFSATraceBS []) -- filled in elsewhere

    Buffer String
exceptionBuffer <- IO (Buffer String)
forall a. IO (Buffer a)
newBuffer
    ProcessOpts
po <- ProcessOpts -> IO ProcessOpts
resolvePath ProcessOpts :: CmdSpec
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Double
-> [Source]
-> [Destination]
-> [Destination]
-> Bool
-> Bool
-> Bool
-> ProcessOpts
ProcessOpts
        {poCommand :: CmdSpec
poCommand = String -> [String] -> CmdSpec
RawCommand String
prog [String]
args
        ,poCwd :: Maybe String
poCwd = Maybe String
optCwd, poEnv :: Maybe [(String, String)]
poEnv = Maybe [(String, String)]
optEnv, poTimeout :: Maybe Double
poTimeout = Maybe Double
optTimeout
        ,poStdin :: [Source]
poStdin = [ByteString -> Source
SrcBytes ByteString
LBS.empty | Bool
optBinary Bool -> Bool -> Bool
&& Bool -> Bool
not ([Source] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Source]
optStdin)] [Source] -> [Source] -> [Source]
forall a. [a] -> [a] -> [a]
++ [Source]
optStdin
        ,poStdout :: [Destination]
poStdout = [Destination
DestEcho | Bool
optEchoStdout] [Destination] -> [Destination] -> [Destination]
forall a. [a] -> [a] -> [a]
++ (String -> Destination) -> [String] -> [Destination]
forall a b. (a -> b) -> [a] -> [b]
map String -> Destination
DestFile [String]
optFileStdout [Destination] -> [Destination] -> [Destination]
forall a. [a] -> [a] -> [a]
++ [Buffer String -> Destination
DestString Buffer String
exceptionBuffer | Bool
optWithStdout Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
optAsync] [Destination] -> [Destination] -> [Destination]
forall a. [a] -> [a] -> [a]
++ [[Destination]] -> [Destination]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Destination]]
dStdout
        ,poStderr :: [Destination]
poStderr = [Destination
DestEcho | Bool
optEchoStderr] [Destination] -> [Destination] -> [Destination]
forall a. [a] -> [a] -> [a]
++ (String -> Destination) -> [String] -> [Destination]
forall a b. (a -> b) -> [a] -> [b]
map String -> Destination
DestFile [String]
optFileStderr [Destination] -> [Destination] -> [Destination]
forall a. [a] -> [a] -> [a]
++ [Buffer String -> Destination
DestString Buffer String
exceptionBuffer | Bool
optWithStderr Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
optAsync] [Destination] -> [Destination] -> [Destination]
forall a. [a] -> [a] -> [a]
++ [[Destination]] -> [Destination]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Destination]]
dStderr
        ,poAsync :: Bool
poAsync = Bool
optAsync
        ,poCloseFds :: Bool
poCloseFds = Bool
optCloseFds
        ,poGroup :: Bool
poGroup = Bool
optProcessGroup
        }
    (Double
dur,(ProcessHandle
pid,ExitCode
exit)) <- IO (ProcessHandle, ExitCode)
-> IO (Double, (ProcessHandle, ExitCode))
forall (m :: * -> *) a. MonadIO m => m a -> m (Double, a)
duration (IO (ProcessHandle, ExitCode)
 -> IO (Double, (ProcessHandle, ExitCode)))
-> IO (ProcessHandle, ExitCode)
-> IO (Double, (ProcessHandle, ExitCode))
forall a b. (a -> b) -> a -> b
$ ProcessOpts -> IO (ProcessHandle, ExitCode)
process ProcessOpts
po
    if ExitCode
exit ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
|| ExitCode -> Result
ResultCode ExitCode
ExitSuccess Result -> [Result] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Result]
results then
        ((Double -> ProcessHandle -> ExitCode -> IO Result) -> IO Result)
-> [Double -> ProcessHandle -> ExitCode -> IO Result]
-> IO [Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Double -> ProcessHandle -> ExitCode -> IO Result
f -> Double -> ProcessHandle -> ExitCode -> IO Result
f Double
dur ProcessHandle
pid ExitCode
exit) [Double -> ProcessHandle -> ExitCode -> IO Result]
resultBuild
     else do
        [String]
exceptionBuffer <- Buffer String -> IO [String]
forall a. Buffer a -> IO [a]
readBuffer Buffer String
exceptionBuffer
        let captured :: [String]
captured = [String
"Stderr" | Bool
optWithStderr] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Stdout" | Bool
optWithStdout]
        String
cwd <- case Maybe String
optCwd of
            Maybe String
Nothing -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
            Just String
v -> do
                String
v <- String -> IO String
canonicalizePath String
v IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` IO String -> IOException -> IO String
forall a b. a -> b -> a
const (String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
v)
                String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Current directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        IO [Result] -> IO [Result]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Result] -> IO [Result]) -> IO [Result] -> IO [Result]
forall a b. (a -> b) -> a -> b
$ String -> IO [Result]
forall a. Partial => String -> IO a
errorIO (String -> IO [Result]) -> String -> IO [Result]
forall a b. (a -> b) -> a -> b
$
            String
"Development.Shake." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funcName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", system command failed\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"Command line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optRealCommand String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            (if String
optRealCommand String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
optUserCommand then String
"Original command line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optUserCommand String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
cwd String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"Exit code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (case ExitCode
exit of ExitFailure Int
i -> Int
i; ExitCode
_ -> Int
0) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
captured then String
"Stderr not captured because WithStderr False was used\n"
            else if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
exceptionBuffer then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " [String]
captured String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
captured Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"was" else String
"were") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" empty"
            else String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " [String]
captured String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
exceptionBuffer)


mergeCwd :: [FilePath] -> Maybe FilePath
mergeCwd :: [String] -> Maybe String
mergeCwd [] = Maybe String
forall a. Maybe a
Nothing
mergeCwd [String]
xs = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 String -> String -> String
(</>) [String]
xs

-- | Apply all environment operations, to produce a new environment to use.
resolveEnv :: [CmdOption] -> IO (Maybe [(String, String)])
resolveEnv :: [CmdOption] -> IO (Maybe [(String, String)])
resolveEnv [CmdOption]
opts
    | [[(String, String)]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[(String, String)]]
env, [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
addEnv, [([String], [String])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([String], [String])]
addPath, [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
remEnv = Maybe [(String, String)] -> IO (Maybe [(String, String)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(String, String)]
forall a. Maybe a
Nothing
    | Bool
otherwise = [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just ([(String, String)] -> Maybe [(String, String)])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> Maybe [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> [(String, String)]
forall b. [(String, b)] -> [(String, b)]
unique ([(String, String)] -> [(String, String)])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> [(String, String)]
tweakPath ([(String, String)] -> [(String, String)])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
addEnv) ([(String, String)] -> [(String, String)])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> [String] -> Bool) -> [String] -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem [String]
remEnv (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) ([(String, String)] -> Maybe [(String, String)])
-> IO [(String, String)] -> IO (Maybe [(String, String)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  if [[(String, String)]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[(String, String)]]
env then IO [(String, String)]
getEnvironment else [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, String)]]
env)
    where
        env :: [[(String, String)]]
env = [[(String, String)]
x | Env [(String, String)]
x <- [CmdOption]
opts]
        addEnv :: [(String, String)]
addEnv = [(String
x,String
y) | AddEnv String
x String
y <- [CmdOption]
opts]
        remEnv :: [String]
remEnv = [String
x | RemEnv String
x <- [CmdOption]
opts]
        addPath :: [([String], [String])]
addPath = [([String]
x,[String]
y) | AddPath [String]
x [String]
y <- [CmdOption]
opts]

        newPath :: String -> String
newPath String
mid = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [[String]]
forall a. [a] -> [a]
reverse ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ (([String], [String]) -> [String])
-> [([String], [String])] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ([String], [String]) -> [String]
forall a b. (a, b) -> a
fst [([String], [String])]
addPath) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
mid | String
mid String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (([String], [String]) -> [String])
-> [([String], [String])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String], [String]) -> [String]
forall a b. (a, b) -> b
snd [([String], [String])]
addPath
        isPath :: String -> Bool
isPath String
x = (if Bool
isWindows then String -> String
upper else String -> String
forall a. a -> a
id) String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"PATH"
        tweakPath :: [(String, String)] -> [(String, String)]
tweakPath [(String, String)]
xs | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((String, String) -> Bool) -> [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> Bool
isPath (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
xs = (String
"PATH", String -> String
newPath String
"") (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
xs
                     | Bool
otherwise = ((String, String) -> (String, String))
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
a,String
b) -> (String
a, if String -> Bool
isPath String
a then String -> String
newPath String
b else String
b)) [(String, String)]
xs

        unique :: [(String, b)] -> [(String, b)]
unique = [(String, b)] -> [(String, b)]
forall a. [a] -> [a]
reverse ([(String, b)] -> [(String, b)])
-> ([(String, b)] -> [(String, b)])
-> [(String, b)]
-> [(String, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, b) -> String) -> [(String, b)] -> [(String, b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (if Bool
isWindows then String -> String
upper (String -> String)
-> ((String, b) -> String) -> (String, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, b) -> String
forall a b. (a, b) -> a
fst else (String, b) -> String
forall a b. (a, b) -> a
fst) ([(String, b)] -> [(String, b)])
-> ([(String, b)] -> [(String, b)])
-> [(String, b)]
-> [(String, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, b)] -> [(String, b)]
forall a. [a] -> [a]
reverse


-- | If the user specifies a custom $PATH, and not Shell, then try and resolve their prog ourselves.
--   Tricky, because on Windows it doesn't look in the $PATH first.
resolvePath :: ProcessOpts -> IO ProcessOpts
resolvePath :: ProcessOpts -> IO ProcessOpts
resolvePath ProcessOpts
po
    | Just [(String, String)]
e <- ProcessOpts -> Maybe [(String, String)]
poEnv ProcessOpts
po
    , Just (String
_, String
path) <- ((String, String) -> Bool)
-> [(String, String)] -> Maybe (String, String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"PATH" (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isWindows then String -> String
upper else String -> String
forall a. a -> a
id) (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
e
    , RawCommand String
prog [String]
args <- ProcessOpts -> CmdSpec
poCommand ProcessOpts
po
    = do
    let progExe :: String
progExe = if String
prog String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
prog String -> String -> String
-<.> String
exe then String
prog else String
prog String -> String -> String
<.> String
exe
    -- use unsafeInterleaveIO to allow laziness to skip the queries we don't use
    String
pathOld <- IO String -> IO String
forall a. IO a -> IO a
unsafeInterleaveIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"PATH"
    Maybe String
old <- IO (Maybe String) -> IO (Maybe String)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findExecutable String
prog
    Maybe String
new <- IO (Maybe String) -> IO (Maybe String)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> String -> IO (Maybe String)
findExecutableWith (String -> [String]
splitSearchPath String
path) String
progExe
    Maybe String
old2 <- IO (Maybe String) -> IO (Maybe String)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> String -> IO (Maybe String)
findExecutableWith (String -> [String]
splitSearchPath String
pathOld) String
progExe

    Bool
switch<- Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case () of
        ()
_ | String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pathOld -> Bool
False -- The state I can see hasn't changed
          | Maybe String
Nothing <- Maybe String
new -> Bool
False -- I have nothing to offer
          | Maybe String
Nothing <- Maybe String
old -> Bool
True -- I failed last time, so this must be an improvement
          | Just String
old <- Maybe String
old, Just String
new <- Maybe String
new, String -> String -> Bool
equalFilePath String
old String
new -> Bool
False -- no different
          | Just String
old <- Maybe String
old, Just String
old2 <- Maybe String
old2, String -> String -> Bool
equalFilePath String
old String
old2 -> Bool
True -- I could predict last time
          | Bool
otherwise -> Bool
False
    ProcessOpts -> IO ProcessOpts
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcessOpts -> IO ProcessOpts) -> ProcessOpts -> IO ProcessOpts
forall a b. (a -> b) -> a -> b
$ case Maybe String
new of
        Just String
new | Bool
switch -> ProcessOpts
po{poCommand :: CmdSpec
poCommand = String -> [String] -> CmdSpec
RawCommand String
new [String]
args}
        Maybe String
_ -> ProcessOpts
po
resolvePath ProcessOpts
po = ProcessOpts -> IO ProcessOpts
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessOpts
po


-- | Given a list of directories, and a file name, return the complete path if you can find it.
--   Like findExecutable, but with a custom PATH.
findExecutableWith :: [FilePath] -> String -> IO (Maybe FilePath)
findExecutableWith :: [String] -> String -> IO (Maybe String)
findExecutableWith [String]
path String
x = ((String -> IO (Maybe String)) -> [String] -> IO (Maybe String))
-> [String] -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> IO (Maybe String)) -> [String] -> IO (Maybe String)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
</> String
x) [String]
path) ((String -> IO (Maybe String)) -> IO (Maybe String))
-> (String -> IO (Maybe String)) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \String
s ->
    IO Bool
-> IO (Maybe String) -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesFileExist String
s) (Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
s) (Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing)


---------------------------------------------------------------------
-- FIXED ARGUMENT WRAPPER

-- | Collect the @stdout@ of the process.
--   If used, the @stdout@ will not be echoed to the terminal, unless you include 'EchoStdout'.
--   The value type may be either 'String', or either lazy or strict 'ByteString'.
--
--   Note that most programs end their output with a trailing newline, so calling
--   @ghc --numeric-version@ will result in 'Stdout' of @\"6.8.3\\n\"@. If you want to automatically
--   trim the resulting string, see 'StdoutTrim'.
newtype Stdout a = Stdout {Stdout a -> a
fromStdout :: a}

-- | Like 'Stdout' but remove all leading and trailing whitespaces.
newtype StdoutTrim a = StdoutTrim {StdoutTrim a -> a
fromStdoutTrim :: a}

-- | Collect the @stderr@ of the process.
--   If used, the @stderr@ will not be echoed to the terminal, unless you include 'EchoStderr'.
--   The value type may be either 'String', or either lazy or strict 'ByteString'.
newtype Stderr a = Stderr {Stderr a -> a
fromStderr :: a}

-- | Collect the @stdout@ and @stderr@ of the process.
--   If used, the @stderr@ and @stdout@ will not be echoed to the terminal, unless you include 'EchoStdout' and 'EchoStderr'.
--   The value type may be either 'String', or either lazy or strict 'ByteString'.
newtype Stdouterr a = Stdouterr {Stdouterr a -> a
fromStdouterr :: a}

-- | Collect the 'ExitCode' of the process.
--   If you do not collect the exit code, any 'ExitFailure' will cause an exception.
newtype Exit = Exit {Exit -> ExitCode
fromExit :: ExitCode}

-- | Collect the 'ProcessHandle' of the process.
--   If you do collect the process handle, the command will run asyncronously and the call to 'cmd' \/ 'command'
--   will return as soon as the process is spawned. Any 'Stdout' \/ 'Stderr' captures will return empty strings.
newtype Process = Process {Process -> ProcessHandle
fromProcess :: ProcessHandle}

-- | Collect the time taken to execute the process. Can be used in conjunction with 'CmdLine' to
--   write helper functions that print out the time of a result.
--
-- @
-- timer :: ('CmdResult' r, MonadIO m) => (forall r . 'CmdResult' r => m r) -> m r
-- timer act = do
--     ('CmdTime' t, 'CmdLine' x, r) <- act
--     liftIO $ putStrLn $ \"Command \" ++ x ++ \" took \" ++ show t ++ \" seconds\"
--     pure r
--
-- run :: IO ()
-- run = timer $ 'cmd' \"ghc --version\"
-- @
newtype CmdTime = CmdTime {CmdTime -> Double
fromCmdTime :: Double}

-- | Collect the command line used for the process. This command line will be approximate -
--   suitable for user diagnostics, but not for direct execution.
newtype CmdLine = CmdLine {CmdLine -> String
fromCmdLine :: String}

-- | The allowable 'String'-like values that can be captured.
class CmdString a where cmdString :: (Str, Str -> a)
instance CmdString () where cmdString :: (Str, Str -> ())
cmdString = (Str
Unit, \Str
Unit -> ())
instance CmdString String where cmdString :: (Str, Str -> String)
cmdString = (String -> Str
Str String
"", \(Str String
x) -> String
x)
instance CmdString BS.ByteString where cmdString :: (Str, Str -> ByteString)
cmdString = (ByteString -> Str
BS ByteString
BS.empty, \(BS ByteString
x) -> ByteString
x)
instance CmdString LBS.ByteString where cmdString :: (Str, Str -> ByteString)
cmdString = (ByteString -> Str
LBS ByteString
LBS.empty, \(LBS ByteString
x) -> ByteString
x)


class Unit a
instance {-# OVERLAPPING #-} Unit b => Unit (a -> b)
instance {-# OVERLAPPABLE #-} a ~ () => Unit (m a)


-- | A class for specifying what results you want to collect from a process.
--   Values are formed of 'Stdout', 'Stderr', 'Exit' and tuples of those.
class CmdResult a where
    -- Return a list of results (with the right type but dummy data)
    -- and a function to transform a populated set of results into a value
    cmdResult :: ([Result], [Result] -> a)

instance CmdResult Exit where
    cmdResult :: ([Result], [Result] -> Exit)
cmdResult = ([ExitCode -> Result
ResultCode ExitCode
ExitSuccess], \[ResultCode ExitCode
x] -> ExitCode -> Exit
Exit ExitCode
x)

instance CmdResult ExitCode where
    cmdResult :: ([Result], [Result] -> ExitCode)
cmdResult = ([ExitCode -> Result
ResultCode ExitCode
ExitSuccess], \[ResultCode ExitCode
x] -> ExitCode
x)

instance CmdResult Process where
    cmdResult :: ([Result], [Result] -> Process)
cmdResult = ([PID -> Result
ResultProcess PID
PID0], \[ResultProcess (PID ProcessHandle
x)] -> ProcessHandle -> Process
Process ProcessHandle
x)

instance CmdResult ProcessHandle where
    cmdResult :: ([Result], [Result] -> ProcessHandle)
cmdResult = ([PID -> Result
ResultProcess PID
PID0], \[ResultProcess (PID ProcessHandle
x)] -> ProcessHandle
x)

instance CmdResult CmdLine where
    cmdResult :: ([Result], [Result] -> CmdLine)
cmdResult = ([String -> Result
ResultLine String
""], \[ResultLine String
x] -> String -> CmdLine
CmdLine String
x)

instance CmdResult CmdTime where
    cmdResult :: ([Result], [Result] -> CmdTime)
cmdResult = ([Double -> Result
ResultTime Double
0], \[ResultTime Double
x] -> Double -> CmdTime
CmdTime Double
x)

instance CmdResult [FSATrace FilePath] where
    cmdResult :: ([Result], [Result] -> [FSATrace String])
cmdResult = ([[FSATrace String] -> Result
ResultFSATrace []], \[ResultFSATrace [FSATrace String]
x] -> [FSATrace String]
x)

instance CmdResult [FSATrace BS.ByteString] where
    cmdResult :: ([Result], [Result] -> [FSATrace ByteString])
cmdResult = ([[FSATrace ByteString] -> Result
ResultFSATraceBS []], \[ResultFSATraceBS [FSATrace ByteString]
x] -> [FSATrace ByteString]
x)

instance CmdString a => CmdResult (Stdout a) where
    cmdResult :: ([Result], [Result] -> Stdout a)
cmdResult = let (Str
a,Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStdout Str
a], \[ResultStdout Str
x] -> a -> Stdout a
forall a. a -> Stdout a
Stdout (a -> Stdout a) -> a -> Stdout a
forall a b. (a -> b) -> a -> b
$ Str -> a
b Str
x)

instance CmdString a => CmdResult (StdoutTrim a) where
    cmdResult :: ([Result], [Result] -> StdoutTrim a)
cmdResult = let (Str
a,Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStdout Str
a], \[ResultStdout Str
x] -> a -> StdoutTrim a
forall a. a -> StdoutTrim a
StdoutTrim (a -> StdoutTrim a) -> a -> StdoutTrim a
forall a b. (a -> b) -> a -> b
$ Str -> a
b (Str -> a) -> Str -> a
forall a b. (a -> b) -> a -> b
$ Str -> Str
strTrim Str
x)

instance CmdString a => CmdResult (Stderr a) where
    cmdResult :: ([Result], [Result] -> Stderr a)
cmdResult = let (Str
a,Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStderr Str
a], \[ResultStderr Str
x] -> a -> Stderr a
forall a. a -> Stderr a
Stderr (a -> Stderr a) -> a -> Stderr a
forall a b. (a -> b) -> a -> b
$ Str -> a
b Str
x)

instance CmdString a => CmdResult (Stdouterr a) where
    cmdResult :: ([Result], [Result] -> Stdouterr a)
cmdResult = let (Str
a,Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStdouterr Str
a], \[ResultStdouterr Str
x] -> a -> Stdouterr a
forall a. a -> Stdouterr a
Stdouterr (a -> Stdouterr a) -> a -> Stdouterr a
forall a b. (a -> b) -> a -> b
$ Str -> a
b Str
x)

instance CmdResult () where
    cmdResult :: ([Result], [Result] -> ())
cmdResult = ([], \[] -> ())

instance (CmdResult x1, CmdResult x2) => CmdResult (x1,x2) where
    cmdResult :: ([Result], [Result] -> (x1, x2))
cmdResult = ([Result]
a1[Result] -> [Result] -> [Result]
forall a. [a] -> [a] -> [a]
++[Result]
a2, \[Result]
rs -> let ([Result]
r1,[Result]
r2) = Int -> [Result] -> ([Result], [Result])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Result] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Result]
a1) [Result]
rs in ([Result] -> x1
b1 [Result]
r1, [Result] -> x2
b2 [Result]
r2))
        where ([Result]
a1,[Result] -> x1
b1) = ([Result], [Result] -> x1)
forall a. CmdResult a => ([Result], [Result] -> a)
cmdResult
              ([Result]
a2,[Result] -> x2
b2) = ([Result], [Result] -> x2)
forall a. CmdResult a => ([Result], [Result] -> a)
cmdResult

cmdResultWith :: forall b c. CmdResult b => (b -> c) -> ([Result], [Result] -> c)
cmdResultWith :: (b -> c) -> ([Result], [Result] -> c)
cmdResultWith b -> c
f = (([Result] -> b) -> [Result] -> c)
-> ([Result], [Result] -> b) -> ([Result], [Result] -> c)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (b -> c
f (b -> c) -> ([Result] -> b) -> [Result] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ([Result], [Result] -> b)
forall a. CmdResult a => ([Result], [Result] -> a)
cmdResult

instance (CmdResult x1, CmdResult x2, CmdResult x3) => CmdResult (x1,x2,x3) where
    cmdResult :: ([Result], [Result] -> (x1, x2, x3))
cmdResult = ((x1, (x2, x3)) -> (x1, x2, x3))
-> ([Result], [Result] -> (x1, x2, x3))
forall b c. CmdResult b => (b -> c) -> ([Result], [Result] -> c)
cmdResultWith (((x1, (x2, x3)) -> (x1, x2, x3))
 -> ([Result], [Result] -> (x1, x2, x3)))
-> ((x1, (x2, x3)) -> (x1, x2, x3))
-> ([Result], [Result] -> (x1, x2, x3))
forall a b. (a -> b) -> a -> b
$ \(x1
a,(x2
b,x3
c)) -> (x1
a,x2
b,x3
c)

instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4) => CmdResult (x1,x2,x3,x4) where
    cmdResult :: ([Result], [Result] -> (x1, x2, x3, x4))
cmdResult = ((x1, (x2, x3, x4)) -> (x1, x2, x3, x4))
-> ([Result], [Result] -> (x1, x2, x3, x4))
forall b c. CmdResult b => (b -> c) -> ([Result], [Result] -> c)
cmdResultWith (((x1, (x2, x3, x4)) -> (x1, x2, x3, x4))
 -> ([Result], [Result] -> (x1, x2, x3, x4)))
-> ((x1, (x2, x3, x4)) -> (x1, x2, x3, x4))
-> ([Result], [Result] -> (x1, x2, x3, x4))
forall a b. (a -> b) -> a -> b
$ \(x1
a,(x2
b,x3
c,x4
d)) -> (x1
a,x2
b,x3
c,x4
d)

instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4, CmdResult x5) => CmdResult (x1,x2,x3,x4,x5) where
    cmdResult :: ([Result], [Result] -> (x1, x2, x3, x4, x5))
cmdResult = ((x1, (x2, x3, x4, x5)) -> (x1, x2, x3, x4, x5))
-> ([Result], [Result] -> (x1, x2, x3, x4, x5))
forall b c. CmdResult b => (b -> c) -> ([Result], [Result] -> c)
cmdResultWith (((x1, (x2, x3, x4, x5)) -> (x1, x2, x3, x4, x5))
 -> ([Result], [Result] -> (x1, x2, x3, x4, x5)))
-> ((x1, (x2, x3, x4, x5)) -> (x1, x2, x3, x4, x5))
-> ([Result], [Result] -> (x1, x2, x3, x4, x5))
forall a b. (a -> b) -> a -> b
$ \(x1
a,(x2
b,x3
c,x4
d,x5
e)) -> (x1
a,x2
b,x3
c,x4
d,x5
e)


-- | Execute a system command. Before running 'command' make sure you 'Development.Shake.need' any files
--   that are used by the command.
--
--   This function takes a list of options (often just @[]@, see 'CmdOption' for the available
--   options), the name of the executable (either a full name, or a program on the @$PATH@) and
--   a list of arguments. The result is often @()@, but can be a tuple containg any of 'Stdout',
--   'Stderr' and 'Exit'. Some examples:
--
-- @
-- 'command_' [] \"gcc\" [\"-c\",\"myfile.c\"]                          -- compile a file, throwing an exception on failure
-- 'Exit' c <- 'command' [] \"gcc\" [\"-c\",myfile]                     -- run a command, recording the exit code
-- ('Exit' c, 'Stderr' err) <- 'command' [] \"gcc\" [\"-c\",\"myfile.c\"]   -- run a command, recording the exit code and error output
-- 'Stdout' out <- 'command' [] \"gcc\" [\"-MM\",\"myfile.c\"]            -- run a command, recording the output
-- 'command_' ['Cwd' \"generated\"] \"gcc\" [\"-c\",myfile]               -- run a command in a directory
-- @
--
--   Unless you retrieve the 'ExitCode' using 'Exit', any 'ExitFailure' will throw an error, including
--   the 'Stderr' in the exception message. If you capture the 'Stdout' or 'Stderr', that stream will not be echoed to the console,
--   unless you use the option 'EchoStdout' or 'EchoStderr'.
--
--   If you use 'command' inside a @do@ block and do not use the result, you may get a compile-time error about being
--   unable to deduce 'CmdResult'. To avoid this error, use 'command_'.
--
--   By default the @stderr@ stream will be captured for use in error messages, and also echoed. To only echo
--   pass @'WithStderr' 'False'@, which causes no streams to be captured by Shake, and certain programs (e.g. @gcc@)
--   to detect they are running in a terminal.
command :: (Partial, CmdResult r) => [CmdOption] -> String -> [String] -> Action r
command :: [CmdOption] -> String -> [String] -> Action r
command [CmdOption]
opts String
x [String]
xs = (Partial => Action r) -> Action r
forall a. Partial => (Partial => a) -> a
withFrozenCallStack ((Partial => Action r) -> Action r)
-> (Partial => Action r) -> Action r
forall a b. (a -> b) -> a -> b
$ [Result] -> r
b ([Result] -> r) -> Action [Result] -> Action r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Partial => Params -> Action [Result]
Params -> Action [Result]
commandExplicitAction (String -> [CmdOption] -> [Result] -> String -> [String] -> Params
Params String
"command" [CmdOption]
opts [Result]
a String
x [String]
xs)
    where ([Result]
a,[Result] -> r
b) = ([Result], [Result] -> r)
forall a. CmdResult a => ([Result], [Result] -> a)
cmdResult

-- | A version of 'command' where you do not require any results, used to avoid errors about being unable
--   to deduce 'CmdResult'.
command_ :: Partial => [CmdOption] -> String -> [String] -> Action ()
command_ :: [CmdOption] -> String -> [String] -> Action ()
command_ [CmdOption]
opts String
x [String]
xs = (Partial => Action ()) -> Action ()
forall a. Partial => (Partial => a) -> a
withFrozenCallStack ((Partial => Action ()) -> Action ())
-> (Partial => Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$ Action [Result] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [Result] -> Action ()) -> Action [Result] -> Action ()
forall a b. (a -> b) -> a -> b
$ Partial => Params -> Action [Result]
Params -> Action [Result]
commandExplicitAction (String -> [CmdOption] -> [Result] -> String -> [String] -> Params
Params String
"command_" [CmdOption]
opts [] String
x [String]
xs)


---------------------------------------------------------------------
-- VARIABLE ARGUMENT WRAPPER

-- | A type annotation, equivalent to the first argument, but in variable argument contexts,
--   gives a clue as to what return type is expected (not actually enforced).
type a :-> t = a


-- | Build or execute a system command. Before using 'cmd' to run a command, make sure you 'Development.Shake.need' any files
--   that are used by the command.
--
-- * @String@ arguments are treated as a list of whitespace separated arguments.
--
-- * @[String]@ arguments are treated as a list of literal arguments.
--
-- * 'CmdOption' arguments are used as options.
--
-- * 'CmdArgument' arguments, which can be built by 'cmd' itself, are spliced into the containing command.
--
--   Typically only string literals should be passed as @String@ arguments. When using variables
--   prefer @[myvar]@ so that if @myvar@ contains spaces they are properly escaped.
--
--   As some examples, here are some calls, and the resulting command string:
--
-- @
-- 'cmd_' \"git log --pretty=\" \"oneline\"           -- git log --pretty= oneline
-- 'cmd_' \"git log --pretty=\" [\"oneline\"]         -- git log --pretty= oneline
-- 'cmd_' \"git log\" (\"--pretty=\" ++ \"oneline\")    -- git log --pretty=oneline
-- 'cmd_' \"git log\" (\"--pretty=\" ++ \"one line\")   -- git log --pretty=one line
-- 'cmd_' \"git log\" [\"--pretty=\" ++ \"one line\"]   -- git log "--pretty=one line"
-- @
--
--   More examples, including return values, see this translation of the examples given for the 'command' function:
--
-- @
-- 'cmd_' \"gcc -c myfile.c\"                                       -- compile a file, throwing an exception on failure
-- 'Exit' c <- 'cmd' \"gcc -c\" [myfile]                              -- run a command, recording the exit code
-- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\"                -- run a command, recording the exit code and error output
-- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\"                         -- run a command, recording the output
-- 'cmd' ('Cwd' \"generated\") \"gcc -c\" [myfile] :: 'Action' ()         -- run a command in a directory
--
-- let gccCommand = 'cmd' \"gcc -c\" :: 'CmdArgument'                 -- build a sub-command. 'cmd' can return 'CmdArgument' values as well as execute commands
-- cmd ('Cwd' \"generated\") gccCommand [myfile]                 -- splice that command into a greater command
-- @
--
--   If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being
--   unable to deduce 'CmdResult'. To avoid this error, use 'cmd_'. If you enable @OverloadedStrings@ or @OverloadedLists@
--   you may have to give type signatures to the arguments, or use the more constrained 'command' instead.
--
--   The 'cmd' function can also be run in the 'IO' monad, but then 'Traced' is ignored and command lines are not echoed.
--   As an example:
--
-- @
-- 'cmd' ('Cwd' \"generated\") 'Shell' \"gcc -c myfile.c\" :: IO ()
-- @
cmd :: (Partial, CmdArguments args) => args :-> Action r
cmd :: args :-> Action r
cmd = (Partial => args :-> Action r) -> args :-> Action r
forall a. Partial => (Partial => a) -> a
withFrozenCallStack ((Partial => args :-> Action r) -> args :-> Action r)
-> (Partial => args :-> Action r) -> args :-> Action r
forall a b. (a -> b) -> a -> b
$ CmdArgument -> args :-> Action r
forall t. (CmdArguments t, Partial) => CmdArgument -> t
cmdArguments CmdArgument
forall a. Monoid a => a
mempty

-- | See 'cmd'. Same as 'cmd' except with a unit result.
-- 'cmd' is to 'cmd_' as 'command' is to 'command_'.
cmd_ :: (Partial, CmdArguments args, Unit args) => args :-> Action ()
cmd_ :: args :-> Action ()
cmd_ = (Partial => args :-> Action ()) -> args :-> Action ()
forall a. Partial => (Partial => a) -> a
withFrozenCallStack Partial => args :-> Action ()
forall args r. (Partial, CmdArguments args) => args
cmd

-- | The arguments to 'cmd' - see 'cmd' for examples and semantics.
newtype CmdArgument = CmdArgument [Either CmdOption String]
  deriving (CmdArgument -> CmdArgument -> Bool
(CmdArgument -> CmdArgument -> Bool)
-> (CmdArgument -> CmdArgument -> Bool) -> Eq CmdArgument
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CmdArgument -> CmdArgument -> Bool
$c/= :: CmdArgument -> CmdArgument -> Bool
== :: CmdArgument -> CmdArgument -> Bool
$c== :: CmdArgument -> CmdArgument -> Bool
Eq, b -> CmdArgument -> CmdArgument
NonEmpty CmdArgument -> CmdArgument
CmdArgument -> CmdArgument -> CmdArgument
(CmdArgument -> CmdArgument -> CmdArgument)
-> (NonEmpty CmdArgument -> CmdArgument)
-> (forall b. Integral b => b -> CmdArgument -> CmdArgument)
-> Semigroup CmdArgument
forall b. Integral b => b -> CmdArgument -> CmdArgument
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> CmdArgument -> CmdArgument
$cstimes :: forall b. Integral b => b -> CmdArgument -> CmdArgument
sconcat :: NonEmpty CmdArgument -> CmdArgument
$csconcat :: NonEmpty CmdArgument -> CmdArgument
<> :: CmdArgument -> CmdArgument -> CmdArgument
$c<> :: CmdArgument -> CmdArgument -> CmdArgument
Semigroup, Semigroup CmdArgument
CmdArgument
Semigroup CmdArgument
-> CmdArgument
-> (CmdArgument -> CmdArgument -> CmdArgument)
-> ([CmdArgument] -> CmdArgument)
-> Monoid CmdArgument
[CmdArgument] -> CmdArgument
CmdArgument -> CmdArgument -> CmdArgument
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CmdArgument] -> CmdArgument
$cmconcat :: [CmdArgument] -> CmdArgument
mappend :: CmdArgument -> CmdArgument -> CmdArgument
$cmappend :: CmdArgument -> CmdArgument -> CmdArgument
mempty :: CmdArgument
$cmempty :: CmdArgument
$cp1Monoid :: Semigroup CmdArgument
Monoid, Int -> CmdArgument -> String -> String
[CmdArgument] -> String -> String
CmdArgument -> String
(Int -> CmdArgument -> String -> String)
-> (CmdArgument -> String)
-> ([CmdArgument] -> String -> String)
-> Show CmdArgument
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CmdArgument] -> String -> String
$cshowList :: [CmdArgument] -> String -> String
show :: CmdArgument -> String
$cshow :: CmdArgument -> String
showsPrec :: Int -> CmdArgument -> String -> String
$cshowsPrec :: Int -> CmdArgument -> String -> String
Show)

-- | The arguments to 'cmd' - see 'cmd' for examples and semantics.
class CmdArguments t where
    -- | Arguments to cmd
    cmdArguments :: Partial => CmdArgument -> t
instance (IsCmdArgument a, CmdArguments r) => CmdArguments (a -> r) where
    cmdArguments :: CmdArgument -> a -> r
cmdArguments CmdArgument
xs a
x = CmdArgument -> r
forall t. (CmdArguments t, Partial) => CmdArgument -> t
cmdArguments (CmdArgument -> r) -> CmdArgument -> r
forall a b. (a -> b) -> a -> b
$ CmdArgument
xs CmdArgument -> CmdArgument -> CmdArgument
forall a. Monoid a => a -> a -> a
`mappend` a -> CmdArgument
forall a. IsCmdArgument a => a -> CmdArgument
toCmdArgument a
x
instance CmdResult r => CmdArguments (Action r) where
    cmdArguments :: CmdArgument -> Action r
cmdArguments (CmdArgument [Either CmdOption String]
x) = case [Either CmdOption String] -> ([CmdOption], [String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either CmdOption String]
x of
        ([CmdOption]
opts, String
x:[String]
xs) -> let ([Result]
a,[Result] -> r
b) = ([Result], [Result] -> r)
forall a. CmdResult a => ([Result], [Result] -> a)
cmdResult in [Result] -> r
b ([Result] -> r) -> Action [Result] -> Action r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Partial => Params -> Action [Result]
Params -> Action [Result]
commandExplicitAction (String -> [CmdOption] -> [Result] -> String -> [String] -> Params
Params String
"cmd" [CmdOption]
opts [Result]
a String
x [String]
xs)
        ([CmdOption], [String])
_ -> String -> Action r
forall a. Partial => String -> a
error String
"Error, no executable or arguments given to Development.Shake.cmd"
instance CmdResult r => CmdArguments (IO r) where
    cmdArguments :: CmdArgument -> IO r
cmdArguments (CmdArgument [Either CmdOption String]
x) = case [Either CmdOption String] -> ([CmdOption], [String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either CmdOption String]
x of
        ([CmdOption]
opts, String
x:[String]
xs) -> let ([Result]
a,[Result] -> r
b) = ([Result], [Result] -> r)
forall a. CmdResult a => ([Result], [Result] -> a)
cmdResult in [Result] -> r
b ([Result] -> r) -> IO [Result] -> IO r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Partial => Params -> IO [Result]
Params -> IO [Result]
commandExplicitIO (String -> [CmdOption] -> [Result] -> String -> [String] -> Params
Params String
"cmd" [CmdOption]
opts [Result]
a String
x [String]
xs)
        ([CmdOption], [String])
_ -> String -> IO r
forall a. Partial => String -> a
error String
"Error, no executable or arguments given to Development.Shake.cmd"
instance CmdArguments CmdArgument where
    cmdArguments :: CmdArgument -> CmdArgument
cmdArguments = CmdArgument -> CmdArgument
forall a. a -> a
id

-- | Class to convert an a  to a CmdArgument
class IsCmdArgument a where
    -- | Conversion to a CmdArgument
    toCmdArgument :: a -> CmdArgument
instance IsCmdArgument () where toCmdArgument :: () -> CmdArgument
toCmdArgument = () -> CmdArgument
forall a. Monoid a => a
mempty
instance IsCmdArgument String where toCmdArgument :: String -> CmdArgument
toCmdArgument = [Either CmdOption String] -> CmdArgument
CmdArgument ([Either CmdOption String] -> CmdArgument)
-> (String -> [Either CmdOption String]) -> String -> CmdArgument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Either CmdOption String)
-> [String] -> [Either CmdOption String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Either CmdOption String
forall a b. b -> Either a b
Right ([String] -> [Either CmdOption String])
-> (String -> [String]) -> String -> [Either CmdOption String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
instance IsCmdArgument [String] where toCmdArgument :: [String] -> CmdArgument
toCmdArgument = [Either CmdOption String] -> CmdArgument
CmdArgument ([Either CmdOption String] -> CmdArgument)
-> ([String] -> [Either CmdOption String])
-> [String]
-> CmdArgument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Either CmdOption String)
-> [String] -> [Either CmdOption String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Either CmdOption String
forall a b. b -> Either a b
Right
instance IsCmdArgument (NonEmpty String) where toCmdArgument :: NonEmpty String -> CmdArgument
toCmdArgument = [String] -> CmdArgument
forall a. IsCmdArgument a => a -> CmdArgument
toCmdArgument ([String] -> CmdArgument)
-> (NonEmpty String -> [String]) -> NonEmpty String -> CmdArgument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance IsCmdArgument CmdOption where toCmdArgument :: CmdOption -> CmdArgument
toCmdArgument = [Either CmdOption String] -> CmdArgument
CmdArgument ([Either CmdOption String] -> CmdArgument)
-> (CmdOption -> [Either CmdOption String])
-> CmdOption
-> CmdArgument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either CmdOption String -> [Either CmdOption String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CmdOption String -> [Either CmdOption String])
-> (CmdOption -> Either CmdOption String)
-> CmdOption
-> [Either CmdOption String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdOption -> Either CmdOption String
forall a b. a -> Either a b
Left
instance IsCmdArgument [CmdOption] where toCmdArgument :: [CmdOption] -> CmdArgument
toCmdArgument = [Either CmdOption String] -> CmdArgument
CmdArgument ([Either CmdOption String] -> CmdArgument)
-> ([CmdOption] -> [Either CmdOption String])
-> [CmdOption]
-> CmdArgument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmdOption -> Either CmdOption String)
-> [CmdOption] -> [Either CmdOption String]
forall a b. (a -> b) -> [a] -> [b]
map CmdOption -> Either CmdOption String
forall a b. a -> Either a b
Left
instance IsCmdArgument CmdArgument where toCmdArgument :: CmdArgument -> CmdArgument
toCmdArgument = CmdArgument -> CmdArgument
forall a. a -> a
id
instance IsCmdArgument a => IsCmdArgument (Maybe a) where toCmdArgument :: Maybe a -> CmdArgument
toCmdArgument = CmdArgument -> (a -> CmdArgument) -> Maybe a -> CmdArgument
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CmdArgument
forall a. Monoid a => a
mempty a -> CmdArgument
forall a. IsCmdArgument a => a -> CmdArgument
toCmdArgument


---------------------------------------------------------------------
-- UTILITIES

-- A better version of showCommandForUser, which doesn't escape so much on Windows
showCommandForUser2 :: FilePath -> [String] -> String
showCommandForUser2 :: String -> [String] -> String
showCommandForUser2 String
cmd [String]
args = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> if String -> Bool
safe String
x then String
x else String -> [String] -> String
showCommandForUser String
x []) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String
cmd String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
    where
        safe :: String -> Bool
safe String
xs = String
xs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" Bool -> Bool -> Bool
&& Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
bad String
xs)
        bad :: Char -> Bool
bad Char
x = Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| (Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isWindows) Bool -> Bool -> Bool
|| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"\"\'" :: String)