{-# 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 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 pre :: [String]
pre post :: [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 (path :: [(String, String)]
path,other :: [(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
== "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
$
        [("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]
forall a. [a] -> [a] -> [a]
++ [String]
post) | (a :: String
a,b :: 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 extra :: [(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 (\(a :: String
a,_) -> 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 x :: String
x) = String -> Str
Str (String -> Str) -> String -> Str
forall a b. (a -> b) -> a -> b
$ String -> String
trim String
x
strTrim (BS x :: 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 x :: 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 x :: ByteString
x = case ByteString -> Maybe (Char, ByteString)
LBS.uncons ByteString
x of
            Just (c :: Char
c, x2 :: ByteString
x2) | Char -> Bool
isSpace Char
c -> ByteString -> ByteString
trimEnd ByteString
x2
            _ -> ByteString
x
strTrim 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 -> Bool
== _ = Bool
True
instance Show PID where show :: PID -> String
show PID0 = "PID0"; show _ = "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{..} call :: 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 = "/bin/sh", args :: [String]
args = ["-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
$ \dir :: String
dir -> do
                let file :: String
file = String
dir 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 = "cmd.exe", args :: [String]
args = ["/d/q/c",String
file]}
    | Bool
otherwise = Params -> m a
call Params
params


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

isFSATrace :: Params -> Bool
isFSATrace :: Params -> Bool
isFSATrace Params{..} = (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 prog :: 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 x :: 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) ["/bin/","/usr/","/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
</> "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
            _ -> 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{..} call :: 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 "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
$ \file :: 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 "" -- 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
            x :: Result
x -> Result
x
    where
        fsaFlags :: String
fsaFlags = String -> [String] -> String
forall a. a -> [a] -> a
lastDef "rwmdqt" [String
x | FSAOptions x :: String
x <- [CmdOption]
opts]

        fsaParams :: String -> Params -> IO Params
fsaParams file :: String
file Params{..} = 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 = "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]
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 _ = Bool
False

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

addFSAOptions :: String -> [CmdOption] -> [CmdOption]
addFSAOptions :: String -> [CmdOption] -> [CmdOption]
addFSAOptions x :: String
x opts :: [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 y :: 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 x :: CmdOption
x = CmdOption
x
addFSAOptions x :: String
x opts :: [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)
Constr
DataType
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 -> Constr
FSATrace a -> DataType
(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 -> Constr
forall a. Data a => FSATrace a -> DataType
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 x :: ByteString
x = case ByteString -> Maybe (ByteString, Char)
BS.unsnoc ByteString
x of
            Just (x :: ByteString
x, '\r') -> ByteString
x
            _ -> ByteString
x

        f :: ByteString -> Maybe (FSATrace ByteString)
f x :: ByteString
x
            | Just (k :: Char
k, x :: ByteString
x) <- ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
x
            , Just ('|', x :: ByteString
x) <- ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
x =
                case Char
k of
                    '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
                    '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
                    '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
                    'm' | (xs :: ByteString
xs, ys :: ByteString
ys) <- (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '|') ByteString
x, Just ('|',ys :: 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
                    '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
                    '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
                    _ -> 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 oparams :: 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{..}<- 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 act :: 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 act :: 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 x :: 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 "" (\x :: String
x -> "cd " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") 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 x :: 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 act :: 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 x :: String
x <- [CmdOption]
opts]
            if String
msg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" 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 act :: 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 "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 act :: Params -> Action [Result]
act = do
            ResultFSATrace pxs :: [FSATrace String]
pxs : res :: [Result]
res <- Params -> Action [Result]
act Params
params{opts :: [CmdOption]
opts = String -> [CmdOption] -> [CmdOption]
addFSAOptions "r" [CmdOption]
opts, results :: [Result]
results = [FSATrace String] -> Result
ResultFSATrace [] Result -> [Result] -> [Result]
forall a. a -> [a] -> [a]
: [Result]
results}
            [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 x :: String
x <- [FSATrace String]
pxs]
            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 cwd :: String
cwd xs :: [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 (\x :: 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 (\x :: 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 act :: Params -> Action [Result]
act = do
            ResultFSATrace xs :: [FSATrace String]
xs : res :: [Result]
res <- Params -> Action [Result]
act Params
params{opts :: [CmdOption]
opts = String -> [CmdOption] -> [CmdOption]
addFSAOptions "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 x :: a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x; reader _ = Maybe a
forall a. Maybe a
Nothing
                writer :: FSATrace a -> Maybe a
writer (FSAWrite x :: a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x; writer (FSAMove x :: a
x _) = a -> Maybe a
forall a. a -> Maybe a
Just a
x; writer _ = Maybe a
forall a. Maybe a
Nothing
                existing :: (a -> Maybe String) -> [a] -> m [String]
existing f :: 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
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
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 -> (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 -> (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{..} -> do
    let (grabStdout :: Bool
grabStdout, grabStderr :: 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)
            _ -> (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 x :: 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 x :: 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 x :: 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 x :: 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
            InheritStdin -> Source -> Maybe Source
forall a. a -> Maybe a
Just Source
SrcInherit
            _ -> 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 x :: Double
x <- [CmdOption]
opts]
    let optWithStdout :: Bool
optWithStdout = Bool -> [Bool] -> Bool
forall a. a -> [a] -> a
lastDef Bool
False [Bool
x | WithStdout x :: Bool
x <- [CmdOption]
opts]
    let optWithStderr :: Bool
optWithStderr = Bool -> [Bool] -> Bool
forall a. a -> [a] -> a
lastDef Bool
True [Bool
x | WithStderr x :: Bool
x <- [CmdOption]
opts]
    let optFileStdout :: [String]
optFileStdout = [String
x | FileStdout x :: String
x <- [CmdOption]
opts]
    let optFileStderr :: [String]
optFileStderr = [String
x | FileStderr x :: 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 x :: 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 x :: 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 x :: 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 f :: ByteString -> Str
f = do (a :: [Destination]
a,b :: 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 x :: 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 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)
    (dStdout :: [[Destination]]
dStdout, dStderr :: [[Destination]]
dStderr, resultBuild :: [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 _ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \_ _ ex :: 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 _ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \dur :: Double
dur _ _ -> 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 _ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \_ _ _ -> 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 _ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \_ pid :: ProcessHandle
pid _ -> 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    s :: Str
s -> do (a :: [Destination]
a,b :: 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 , [], \_ _ _ -> (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    s :: Str
s -> do (a :: [Destination]
a,b :: 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 , \_ _ _ -> (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 s :: Str
s -> do (a :: [Destination]
a,b :: 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 , \_ _ _ -> (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 _ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \_ _ _ -> 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 _ -> ([Destination], [Destination],
 Double -> ProcessHandle -> ExitCode -> IO Result)
-> IO
     ([Destination], [Destination],
      Double -> ProcessHandle -> ExitCode -> IO Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], \_ _ _ -> 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
        }
    (dur :: Double
dur,(pid :: ProcessHandle
pid,exit :: 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 (\f :: 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 = ["Stderr" | Bool
optWithStderr] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["Stdout" | Bool
optWithStdout]
        String
cwd <- case Maybe String
optCwd of
            Nothing -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ""
            Just v :: 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
$ "Current directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\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
$
            "Development.Shake." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funcName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", system command failed\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "Command line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optRealCommand String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\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 "Original command line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optUserCommand String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" else "") String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
cwd String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "Exit code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (case ExitCode
exit of ExitFailure i :: Int
i -> Int
i; _ -> 0) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
captured then "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 " and " [String]
captured String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " 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
== 1 then "was" else "were") String -> String -> String
forall a. [a] -> [a] -> [a]
++ " empty"
            else String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " and " [String]
captured String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":\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 xs :: [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 opts :: [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 x :: [(String, String)]
x <- [CmdOption]
opts]
        addEnv :: [(String, String)]
addEnv = [(String
x,String
y) | AddEnv x :: String
x y :: String
y <- [CmdOption]
opts]
        remEnv :: [String]
remEnv = [String
x | RemEnv x :: String
x <- [CmdOption]
opts]
        addPath :: [([String], [String])]
addPath = [([String]
x,[String]
y) | AddPath x :: [String]
x y :: [String]
y <- [CmdOption]
opts]

        newPath :: String -> String
newPath mid :: 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]
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 x :: 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
== "PATH"
        tweakPath :: [(String, String)] -> [(String, String)]
tweakPath xs :: [(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 = ("PATH", String -> String
newPath "") (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 (\(a :: String
a,b :: 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 po :: ProcessOpts
po
    | Just e :: [(String, String)]
e <- ProcessOpts -> Maybe [(String, String)]
poEnv ProcessOpts
po
    , Just (_, path :: 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
(==) "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 prog :: String
prog args :: [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 "" (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 "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 old :: String
old <- Maybe String
old, Just new :: String
new <- Maybe String
new, String -> String -> Bool
equalFilePath String
old String
new -> Bool
False -- no different
          | Just old :: String
old <- Maybe String
old, Just old2 :: 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 new :: String
new | Bool
switch -> ProcessOpts
po{poCommand :: CmdSpec
poCommand = String -> [String] -> CmdSpec
RawCommand String
new [String]
args}
        _ -> ProcessOpts
po
resolvePath po :: 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 path :: [String]
path x :: 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
$ \s :: 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, \Unit -> ())
instance CmdString String where cmdString :: (Str, Str -> String)
cmdString = (String -> Str
Str "", \(Str x :: String
x) -> String
x)
instance CmdString BS.ByteString where cmdString :: (Str, Str -> ByteString)
cmdString = (ByteString -> Str
BS ByteString
BS.empty, \(BS x :: ByteString
x) -> ByteString
x)
instance CmdString LBS.ByteString where cmdString :: (Str, Str -> ByteString)
cmdString = (ByteString -> Str
LBS ByteString
LBS.empty, \(LBS x :: 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 x :: ExitCode
x] -> ExitCode -> Exit
Exit ExitCode
x)

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

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

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

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

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

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

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

instance CmdString a => CmdResult (Stdout a) where
    cmdResult :: ([Result], [Result] -> Stdout a)
cmdResult = let (a :: Str
a,b :: Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStdout Str
a], \[ResultStdout x :: 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 (a :: Str
a,b :: Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStdout Str
a], \[ResultStdout x :: 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 (a :: Str
a,b :: Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStderr Str
a], \[ResultStderr x :: 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 (a :: Str
a,b :: Str -> a
b) = (Str, Str -> a)
forall a. CmdString a => (Str, Str -> a)
cmdString in ([Str -> Result
ResultStdouterr Str
a], \[ResultStdouterr x :: 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, \rs :: [Result]
rs -> let (r1 :: [Result]
r1,r2 :: [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 (a1 :: [Result]
a1,b1 :: [Result] -> x1
b1) = ([Result], [Result] -> x1)
forall a. CmdResult a => ([Result], [Result] -> a)
cmdResult
              (a2 :: [Result]
a2,b2 :: [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 f :: 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
$ \(a :: x1
a,(b :: x2
b,c :: 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
$ \(a :: x1
a,(b :: x2
b,c :: x3
c,d :: 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
$ \(a :: x1
a,(b :: x2
b,c :: x3
c,d :: x4
d,e :: 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 opts :: [CmdOption]
opts x :: String
x xs :: [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 "command" [CmdOption]
opts [Result]
a String
x [String]
xs)
    where (a :: [Result]
a,b :: [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_ opts :: [CmdOption]
opts x :: String
x xs :: [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 "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 xs :: CmdArgument
xs x :: 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 x :: [Either CmdOption String]
x) = case [Either CmdOption String] -> ([CmdOption], [String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either CmdOption String]
x of
        (opts :: [CmdOption]
opts, x :: String
x:xs :: [String]
xs) -> let (a :: [Result]
a,b :: [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 "cmd" [CmdOption]
opts [Result]
a String
x [String]
xs)
        _ -> String -> Action r
forall a. Partial => String -> a
error "Error, no executable or arguments given to Development.Shake.cmd"
instance CmdResult r => CmdArguments (IO r) where
    cmdArguments :: CmdArgument -> IO r
cmdArguments (CmdArgument x :: [Either CmdOption String]
x) = case [Either CmdOption String] -> ([CmdOption], [String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either CmdOption String]
x of
        (opts :: [CmdOption]
opts, x :: String
x:xs :: [String]
xs) -> let (a :: [Result]
a,b :: [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 "cmd" [CmdOption]
opts [Result]
a String
x [String]
xs)
        _ -> String -> IO r
forall a. Partial => String -> a
error "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 cmd :: String
cmd args :: [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 (\x :: 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 xs :: String
xs = String
xs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "" 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 x :: Char
x = Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| (Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' 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)