{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Program.Run
-- Copyright   :  Duncan Coutts 2009
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides a data type for program invocations and functions to
-- run them.

module Distribution.Simple.Program.Run (
    ProgramInvocation(..),
    IOEncoding(..),
    emptyProgramInvocation,
    simpleProgramInvocation,
    programInvocation,
    multiStageProgramInvocation,

    runProgramInvocation,
    getProgramInvocationOutput,
    getProgramInvocationOutputAndErrors,

    getEffectiveEnvironment,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Compat.Environment

import qualified Data.Map as Map
import System.FilePath
import System.Exit
         ( ExitCode(..), exitWith )

-- | Represents a specific invocation of a specific program.
--
-- This is used as an intermediate type between deciding how to call a program
-- and actually doing it. This provides the opportunity to the caller to
-- adjust how the program will be called. These invocations can either be run
-- directly or turned into shell or batch scripts.
--
data ProgramInvocation = ProgramInvocation {
       ProgramInvocation -> FilePath
progInvokePath  :: FilePath,
       ProgramInvocation -> [FilePath]
progInvokeArgs  :: [String],
       ProgramInvocation -> [(FilePath, Maybe FilePath)]
progInvokeEnv   :: [(String, Maybe String)],
       -- Extra paths to add to PATH
       ProgramInvocation -> [FilePath]
progInvokePathEnv :: [FilePath],
       ProgramInvocation -> Maybe FilePath
progInvokeCwd   :: Maybe FilePath,
       ProgramInvocation -> Maybe FilePath
progInvokeInput :: Maybe String,
       ProgramInvocation -> IOEncoding
progInvokeInputEncoding  :: IOEncoding,
       ProgramInvocation -> IOEncoding
progInvokeOutputEncoding :: IOEncoding
     }

data IOEncoding = IOEncodingText   -- locale mode text
                | IOEncodingUTF8   -- always utf8

encodeToIOData :: IOEncoding -> String -> IOData
encodeToIOData :: IOEncoding -> FilePath -> IOData
encodeToIOData IOEncoding
IOEncodingText = FilePath -> IOData
IODataText
encodeToIOData IOEncoding
IOEncodingUTF8 = ByteString -> IOData
IODataBinary (ByteString -> IOData)
-> (FilePath -> ByteString) -> FilePath -> IOData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
toUTF8LBS

emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation =
  ProgramInvocation :: FilePath
-> [FilePath]
-> [(FilePath, Maybe FilePath)]
-> [FilePath]
-> Maybe FilePath
-> Maybe FilePath
-> IOEncoding
-> IOEncoding
-> ProgramInvocation
ProgramInvocation {
    progInvokePath :: FilePath
progInvokePath  = FilePath
"",
    progInvokeArgs :: [FilePath]
progInvokeArgs  = [],
    progInvokeEnv :: [(FilePath, Maybe FilePath)]
progInvokeEnv   = [],
    progInvokePathEnv :: [FilePath]
progInvokePathEnv = [],
    progInvokeCwd :: Maybe FilePath
progInvokeCwd   = Maybe FilePath
forall a. Maybe a
Nothing,
    progInvokeInput :: Maybe FilePath
progInvokeInput = Maybe FilePath
forall a. Maybe a
Nothing,
    progInvokeInputEncoding :: IOEncoding
progInvokeInputEncoding  = IOEncoding
IOEncodingText,
    progInvokeOutputEncoding :: IOEncoding
progInvokeOutputEncoding = IOEncoding
IOEncodingText
  }

simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation
simpleProgramInvocation :: FilePath -> [FilePath] -> ProgramInvocation
simpleProgramInvocation FilePath
path [FilePath]
args =
  ProgramInvocation
emptyProgramInvocation {
    progInvokePath :: FilePath
progInvokePath  = FilePath
path,
    progInvokeArgs :: [FilePath]
progInvokeArgs  = [FilePath]
args
  }

programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation :: ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [FilePath]
args =
  ProgramInvocation
emptyProgramInvocation {
    progInvokePath :: FilePath
progInvokePath = ConfiguredProgram -> FilePath
programPath ConfiguredProgram
prog,
    progInvokeArgs :: [FilePath]
progInvokeArgs = ConfiguredProgram -> [FilePath]
programDefaultArgs ConfiguredProgram
prog
                  [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
args
                  [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> [FilePath]
programOverrideArgs ConfiguredProgram
prog,
    progInvokeEnv :: [(FilePath, Maybe FilePath)]
progInvokeEnv  = ConfiguredProgram -> [(FilePath, Maybe FilePath)]
programOverrideEnv ConfiguredProgram
prog
  }


runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity
  ProgramInvocation {
    progInvokePath :: ProgramInvocation -> FilePath
progInvokePath  = FilePath
path,
    progInvokeArgs :: ProgramInvocation -> [FilePath]
progInvokeArgs  = [FilePath]
args,
    progInvokeEnv :: ProgramInvocation -> [(FilePath, Maybe FilePath)]
progInvokeEnv   = [],
    progInvokePathEnv :: ProgramInvocation -> [FilePath]
progInvokePathEnv = [],
    progInvokeCwd :: ProgramInvocation -> Maybe FilePath
progInvokeCwd   = Maybe FilePath
Nothing,
    progInvokeInput :: ProgramInvocation -> Maybe FilePath
progInvokeInput = Maybe FilePath
Nothing
  } =
  Verbosity -> FilePath -> [FilePath] -> IO ()
rawSystemExit Verbosity
verbosity FilePath
path [FilePath]
args

runProgramInvocation Verbosity
verbosity
  ProgramInvocation {
    progInvokePath :: ProgramInvocation -> FilePath
progInvokePath  = FilePath
path,
    progInvokeArgs :: ProgramInvocation -> [FilePath]
progInvokeArgs  = [FilePath]
args,
    progInvokeEnv :: ProgramInvocation -> [(FilePath, Maybe FilePath)]
progInvokeEnv   = [(FilePath, Maybe FilePath)]
envOverrides,
    progInvokePathEnv :: ProgramInvocation -> [FilePath]
progInvokePathEnv = [FilePath]
extraPath,
    progInvokeCwd :: ProgramInvocation -> Maybe FilePath
progInvokeCwd   = Maybe FilePath
mcwd,
    progInvokeInput :: ProgramInvocation -> Maybe FilePath
progInvokeInput = Maybe FilePath
Nothing
  } = do
    [(FilePath, Maybe FilePath)]
pathOverride <- [(FilePath, Maybe FilePath)]
-> [FilePath] -> NoCallStackIO [(FilePath, Maybe FilePath)]
getExtraPathEnv [(FilePath, Maybe FilePath)]
envOverrides [FilePath]
extraPath
    Maybe [(FilePath, FilePath)]
menv <- [(FilePath, Maybe FilePath)]
-> NoCallStackIO (Maybe [(FilePath, FilePath)])
getEffectiveEnvironment ([(FilePath, Maybe FilePath)]
envOverrides [(FilePath, Maybe FilePath)]
-> [(FilePath, Maybe FilePath)] -> [(FilePath, Maybe FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe FilePath)]
pathOverride)
    ExitCode
exitCode <- Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv Verbosity
verbosity
                                   FilePath
path [FilePath]
args
                                   Maybe FilePath
mcwd Maybe [(FilePath, FilePath)]
menv
                                   Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitCode

runProgramInvocation Verbosity
verbosity
  ProgramInvocation {
    progInvokePath :: ProgramInvocation -> FilePath
progInvokePath  = FilePath
path,
    progInvokeArgs :: ProgramInvocation -> [FilePath]
progInvokeArgs  = [FilePath]
args,
    progInvokeEnv :: ProgramInvocation -> [(FilePath, Maybe FilePath)]
progInvokeEnv   = [(FilePath, Maybe FilePath)]
envOverrides,
    progInvokePathEnv :: ProgramInvocation -> [FilePath]
progInvokePathEnv = [FilePath]
extraPath,
    progInvokeCwd :: ProgramInvocation -> Maybe FilePath
progInvokeCwd   = Maybe FilePath
mcwd,
    progInvokeInput :: ProgramInvocation -> Maybe FilePath
progInvokeInput = Just FilePath
inputStr,
    progInvokeInputEncoding :: ProgramInvocation -> IOEncoding
progInvokeInputEncoding = IOEncoding
encoding
  } = do
    [(FilePath, Maybe FilePath)]
pathOverride <- [(FilePath, Maybe FilePath)]
-> [FilePath] -> NoCallStackIO [(FilePath, Maybe FilePath)]
getExtraPathEnv [(FilePath, Maybe FilePath)]
envOverrides [FilePath]
extraPath
    Maybe [(FilePath, FilePath)]
menv <- [(FilePath, Maybe FilePath)]
-> NoCallStackIO (Maybe [(FilePath, FilePath)])
getEffectiveEnvironment ([(FilePath, Maybe FilePath)]
envOverrides [(FilePath, Maybe FilePath)]
-> [(FilePath, Maybe FilePath)] -> [(FilePath, Maybe FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe FilePath)]
pathOverride)
    (IOData
_, FilePath
errors, ExitCode
exitCode) <- Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe IOData
-> IODataMode
-> IO (IOData, FilePath, ExitCode)
rawSystemStdInOut Verbosity
verbosity
                                    FilePath
path [FilePath]
args
                                    Maybe FilePath
mcwd Maybe [(FilePath, FilePath)]
menv
                                    (IOData -> Maybe IOData
forall a. a -> Maybe a
Just IOData
input) IODataMode
IODataModeBinary
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' exited with an error:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
errors
  where
    input :: IOData
input = IOEncoding -> FilePath -> IOData
encodeToIOData IOEncoding
encoding FilePath
inputStr

getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO FilePath
getProgramInvocationOutput Verbosity
verbosity ProgramInvocation
inv = do
    (FilePath
output, FilePath
errors, ExitCode
exitCode) <- Verbosity -> ProgramInvocation -> IO (FilePath, FilePath, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity ProgramInvocation
inv
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ProgramInvocation -> FilePath
progInvokePath ProgramInvocation
inv FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' exited with an error:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
errors
    FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output


getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation
                                    -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation -> IO (FilePath, FilePath, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity
  ProgramInvocation {
    progInvokePath :: ProgramInvocation -> FilePath
progInvokePath  = FilePath
path,
    progInvokeArgs :: ProgramInvocation -> [FilePath]
progInvokeArgs  = [FilePath]
args,
    progInvokeEnv :: ProgramInvocation -> [(FilePath, Maybe FilePath)]
progInvokeEnv   = [(FilePath, Maybe FilePath)]
envOverrides,
    progInvokePathEnv :: ProgramInvocation -> [FilePath]
progInvokePathEnv = [FilePath]
extraPath,
    progInvokeCwd :: ProgramInvocation -> Maybe FilePath
progInvokeCwd   = Maybe FilePath
mcwd,
    progInvokeInput :: ProgramInvocation -> Maybe FilePath
progInvokeInput = Maybe FilePath
minputStr,
    progInvokeOutputEncoding :: ProgramInvocation -> IOEncoding
progInvokeOutputEncoding = IOEncoding
encoding
  } = do
    let mode :: IODataMode
mode = case IOEncoding
encoding of IOEncoding
IOEncodingUTF8 -> IODataMode
IODataModeBinary
                                IOEncoding
IOEncodingText -> IODataMode
IODataModeText

        decode :: IOData -> FilePath
decode (IODataBinary ByteString
b) = FilePath -> FilePath
normaliseLineEndings (ByteString -> FilePath
fromUTF8LBS ByteString
b)
        decode (IODataText   FilePath
s) = FilePath
s

    [(FilePath, Maybe FilePath)]
pathOverride <- [(FilePath, Maybe FilePath)]
-> [FilePath] -> NoCallStackIO [(FilePath, Maybe FilePath)]
getExtraPathEnv [(FilePath, Maybe FilePath)]
envOverrides [FilePath]
extraPath
    Maybe [(FilePath, FilePath)]
menv <- [(FilePath, Maybe FilePath)]
-> NoCallStackIO (Maybe [(FilePath, FilePath)])
getEffectiveEnvironment ([(FilePath, Maybe FilePath)]
envOverrides [(FilePath, Maybe FilePath)]
-> [(FilePath, Maybe FilePath)] -> [(FilePath, Maybe FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe FilePath)]
pathOverride)
    (IOData
output, FilePath
errors, ExitCode
exitCode) <- Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe IOData
-> IODataMode
-> IO (IOData, FilePath, ExitCode)
rawSystemStdInOut Verbosity
verbosity
                                    FilePath
path [FilePath]
args
                                    Maybe FilePath
mcwd Maybe [(FilePath, FilePath)]
menv
                                    Maybe IOData
input IODataMode
mode
    (FilePath, FilePath, ExitCode) -> IO (FilePath, FilePath, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (IOData -> FilePath
decode IOData
output, FilePath
errors, ExitCode
exitCode)
  where
    input :: Maybe IOData
input = IOEncoding -> FilePath -> IOData
encodeToIOData IOEncoding
encoding (FilePath -> IOData) -> Maybe FilePath -> Maybe IOData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
minputStr

getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> NoCallStackIO [(String, Maybe String)]
getExtraPathEnv :: [(FilePath, Maybe FilePath)]
-> [FilePath] -> NoCallStackIO [(FilePath, Maybe FilePath)]
getExtraPathEnv [(FilePath, Maybe FilePath)]
_ [] = [(FilePath, Maybe FilePath)]
-> NoCallStackIO [(FilePath, Maybe FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getExtraPathEnv [(FilePath, Maybe FilePath)]
env [FilePath]
extras = do
    Maybe FilePath
mb_path <- case FilePath -> [(FilePath, Maybe FilePath)] -> Maybe (Maybe FilePath)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"PATH" [(FilePath, Maybe FilePath)]
env of
                Just Maybe FilePath
x  -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
x
                Maybe (Maybe FilePath)
Nothing -> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"PATH"
    let extra :: FilePath
extra = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] [FilePath]
extras
        path' :: FilePath
path' = case Maybe FilePath
mb_path of
                    Maybe FilePath
Nothing   -> FilePath
extra
                    Just FilePath
path -> FilePath
extra FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
searchPathSeparator Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
path
    [(FilePath, Maybe FilePath)]
-> NoCallStackIO [(FilePath, Maybe FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath
"PATH", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path')]

-- | Return the current environment extended with the given overrides.
-- If an entry is specified twice in @overrides@, the second entry takes
-- precedence.
--
getEffectiveEnvironment :: [(String, Maybe String)]
                        -> NoCallStackIO (Maybe [(String, String)])
getEffectiveEnvironment :: [(FilePath, Maybe FilePath)]
-> NoCallStackIO (Maybe [(FilePath, FilePath)])
getEffectiveEnvironment []        = Maybe [(FilePath, FilePath)]
-> NoCallStackIO (Maybe [(FilePath, FilePath)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
getEffectiveEnvironment [(FilePath, Maybe FilePath)]
overrides =
    ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)]
-> NoCallStackIO (Maybe [(FilePath, FilePath)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)])
-> ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)]
-> Maybe [(FilePath, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FilePath FilePath -> [(FilePath, FilePath)])
-> ([(FilePath, FilePath)] -> Map FilePath FilePath)
-> [(FilePath, FilePath)]
-> [(FilePath, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, Maybe FilePath)]
-> Map FilePath FilePath -> Map FilePath FilePath
forall (t :: * -> *) k a.
(Foldable t, Ord k) =>
t (k, Maybe a) -> Map k a -> Map k a
apply [(FilePath, Maybe FilePath)]
overrides (Map FilePath FilePath -> Map FilePath FilePath)
-> ([(FilePath, FilePath)] -> Map FilePath FilePath)
-> [(FilePath, FilePath)]
-> Map FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) IO [(FilePath, FilePath)]
getEnvironment
  where
    apply :: t (k, Maybe a) -> Map k a -> Map k a
apply t (k, Maybe a)
os Map k a
env = (Map k a -> (k, Maybe a) -> Map k a)
-> Map k a -> t (k, Maybe a) -> Map k a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((k, Maybe a) -> Map k a -> Map k a)
-> Map k a -> (k, Maybe a) -> Map k a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k, Maybe a) -> Map k a -> Map k a
forall k a. Ord k => (k, Maybe a) -> Map k a -> Map k a
update) Map k a
env t (k, Maybe a)
os
    update :: (k, Maybe a) -> Map k a -> Map k a
update (k
var, Maybe a
Nothing)  = k -> Map k a -> Map k a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
var
    update (k
var, Just a
val) = k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
var a
val

-- | Like the unix xargs program. Useful for when we've got very long command
-- lines that might overflow an OS limit on command line length and so you
-- need to invoke a command multiple times to get all the args in.
--
-- It takes four template invocations corresponding to the simple, initial,
-- middle and last invocations. If the number of args given is small enough
-- that we can get away with just a single invocation then the simple one is
-- used:
--
-- > $ simple args
--
-- If the number of args given means that we need to use multiple invocations
-- then the templates for the initial, middle and last invocations are used:
--
-- > $ initial args_0
-- > $ middle  args_1
-- > $ middle  args_2
-- >   ...
-- > $ final   args_n
--
multiStageProgramInvocation
  :: ProgramInvocation
  -> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
  -> [String]
  -> [ProgramInvocation]
multiStageProgramInvocation :: ProgramInvocation
-> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
-> [FilePath]
-> [ProgramInvocation]
multiStageProgramInvocation ProgramInvocation
simple (ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final) [FilePath]
args =

  let argSize :: ProgramInvocation -> Int
argSize ProgramInvocation
inv  = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ProgramInvocation -> FilePath
progInvokePath ProgramInvocation
inv)
                   Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> FilePath -> Int) -> Int -> [FilePath] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
s FilePath
a -> FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s) Int
1 (ProgramInvocation -> [FilePath]
progInvokeArgs ProgramInvocation
inv)
      fixedArgSize :: Int
fixedArgSize = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((ProgramInvocation -> Int) -> [ProgramInvocation] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ProgramInvocation -> Int
argSize [ProgramInvocation
simple, ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final])
      chunkSize :: Int
chunkSize    = Int
maxCommandLineSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fixedArgSize

   in case Int -> [FilePath] -> [[FilePath]]
forall a. Int -> [[a]] -> [[[a]]]
splitChunks Int
chunkSize [FilePath]
args of
        []     -> [ ProgramInvocation
simple ]

        [[FilePath]
c]    -> [ ProgramInvocation
simple  ProgramInvocation -> [FilePath] -> ProgramInvocation
`appendArgs` [FilePath]
c ]

        ([FilePath]
c:[[FilePath]]
cs) -> [ ProgramInvocation
initial ProgramInvocation -> [FilePath] -> ProgramInvocation
`appendArgs` [FilePath]
c ]
               [ProgramInvocation] -> [ProgramInvocation] -> [ProgramInvocation]
forall a. [a] -> [a] -> [a]
++ [ ProgramInvocation
middle  ProgramInvocation -> [FilePath] -> ProgramInvocation
`appendArgs` [FilePath]
c'| [FilePath]
c' <- [[FilePath]] -> [[FilePath]]
forall a. [a] -> [a]
init [[FilePath]]
cs ]
               [ProgramInvocation] -> [ProgramInvocation] -> [ProgramInvocation]
forall a. [a] -> [a] -> [a]
++ [ ProgramInvocation
final   ProgramInvocation -> [FilePath] -> ProgramInvocation
`appendArgs` [FilePath]
c'| let c' :: [FilePath]
c' = [[FilePath]] -> [FilePath]
forall a. [a] -> a
last [[FilePath]]
cs ]

  where
    appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
    ProgramInvocation
inv appendArgs :: ProgramInvocation -> [FilePath] -> ProgramInvocation
`appendArgs` [FilePath]
as = ProgramInvocation
inv { progInvokeArgs :: [FilePath]
progInvokeArgs = ProgramInvocation -> [FilePath]
progInvokeArgs ProgramInvocation
inv [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
as }

    splitChunks :: Int -> [[a]] -> [[[a]]]
    splitChunks :: Int -> [[a]] -> [[[a]]]
splitChunks Int
len = ([[a]] -> Maybe ([[a]], [[a]])) -> [[a]] -> [[[a]]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (([[a]] -> Maybe ([[a]], [[a]])) -> [[a]] -> [[[a]]])
-> ([[a]] -> Maybe ([[a]], [[a]])) -> [[a]] -> [[[a]]]
forall a b. (a -> b) -> a -> b
$ \[[a]]
s ->
      if [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[a]]
s then Maybe ([[a]], [[a]])
forall a. Maybe a
Nothing
                else ([[a]], [[a]]) -> Maybe ([[a]], [[a]])
forall a. a -> Maybe a
Just (Int -> [[a]] -> ([[a]], [[a]])
forall a. Int -> [[a]] -> ([[a]], [[a]])
chunk Int
len [[a]]
s)

    chunk :: Int -> [[a]] -> ([[a]], [[a]])
    chunk :: Int -> [[a]] -> ([[a]], [[a]])
chunk Int
len ([a]
s:[[a]]
_) | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = FilePath -> ([[a]], [[a]])
forall a. HasCallStack => FilePath -> a
error FilePath
toolong
    chunk Int
len [[a]]
ss    = [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
forall a. [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
chunk' [] Int
len [[a]]
ss

    chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
    chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
chunk' [[a]]
acc Int
len ([a]
s:[[a]]
ss)
      | Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len = [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
forall a. [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
chunk' ([a]
s[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
acc) (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
len'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [[a]]
ss
      where len' :: Int
len' = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s
    chunk' [[a]]
acc Int
_   [[a]]
ss     = ([[a]] -> [[a]]
forall a. [a] -> [a]
reverse [[a]]
acc, [[a]]
ss)

    toolong :: FilePath
toolong = FilePath
"multiStageProgramInvocation: a single program arg is larger "
           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"than the maximum command line length!"


--FIXME: discover this at configure time or runtime on unix
-- The value is 32k on Windows and posix specifies a minimum of 4k
-- but all sensible unixes use more than 4k.
-- we could use getSysVar ArgumentLimit but that's in the unix lib
--
maxCommandLineSize :: Int
maxCommandLineSize :: Int
maxCommandLineSize = Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024