{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# 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
  , getProgramInvocationLBS
  , getProgramInvocationOutputAndErrors
  , getEffectiveEnvironment
  ) where

import Distribution.Compat.Prelude
import Prelude ()

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

import System.FilePath (searchPathSeparator)

import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map

-- | 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 -> String
progInvokePath :: FilePath
  , ProgramInvocation -> [String]
progInvokeArgs :: [String]
  , ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv :: [(String, Maybe String)]
  , -- Extra paths to add to PATH
    ProgramInvocation -> [String]
progInvokePathEnv :: [FilePath]
  , ProgramInvocation -> Maybe String
progInvokeCwd :: Maybe FilePath
  , ProgramInvocation -> Maybe IOData
progInvokeInput :: Maybe IOData
  , ProgramInvocation -> IOEncoding
progInvokeInputEncoding :: IOEncoding
  -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.
  , ProgramInvocation -> IOEncoding
progInvokeOutputEncoding :: IOEncoding
  }

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

encodeToIOData :: IOEncoding -> IOData -> IOData
encodeToIOData :: IOEncoding -> IOData -> IOData
encodeToIOData IOEncoding
_ iod :: IOData
iod@(IODataBinary ByteString
_) = IOData
iod
encodeToIOData IOEncoding
IOEncodingText iod :: IOData
iod@(IODataText String
_) = IOData
iod
encodeToIOData IOEncoding
IOEncodingUTF8 (IODataText String
str) = ByteString -> IOData
IODataBinary (String -> ByteString
toUTF8LBS String
str)

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

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

programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args =
  ProgramInvocation
emptyProgramInvocation
    { progInvokePath = programPath prog
    , progInvokeArgs =
        programDefaultArgs prog
          ++ args
          ++ programOverrideArgs prog
    , progInvokeEnv = programOverrideEnv prog
    }

runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = []
    , progInvokePathEnv :: ProgramInvocation -> [String]
progInvokePathEnv = []
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
Nothing
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Maybe IOData
Nothing
    } =
    Verbosity -> String -> [String] -> IO ()
rawSystemExit Verbosity
verbosity String
path [String]
args
runProgramInvocation
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = [(String, Maybe String)]
envOverrides
    , progInvokePathEnv :: ProgramInvocation -> [String]
progInvokePathEnv = [String]
extraPath
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
mcwd
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Maybe IOData
Nothing
    } = do
    [(String, Maybe String)]
pathOverride <- [(String, Maybe String)] -> [String] -> IO [(String, Maybe String)]
getExtraPathEnv [(String, Maybe String)]
envOverrides [String]
extraPath
    Maybe [(String, String)]
menv <- [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment ([(String, Maybe String)]
envOverrides [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++ [(String, Maybe String)]
pathOverride)
    IO ExitCode -> IO ()
maybeExit (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv
        Verbosity
verbosity
        String
path
        [String]
args
        Maybe String
mcwd
        Maybe [(String, String)]
menv
        Maybe Handle
forall a. Maybe a
Nothing
        Maybe Handle
forall a. Maybe a
Nothing
        Maybe Handle
forall a. Maybe a
Nothing
runProgramInvocation
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = [(String, Maybe String)]
envOverrides
    , progInvokePathEnv :: ProgramInvocation -> [String]
progInvokePathEnv = [String]
extraPath
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
mcwd
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Just IOData
inputStr
    , progInvokeInputEncoding :: ProgramInvocation -> IOEncoding
progInvokeInputEncoding = IOEncoding
encoding
    } = do
    [(String, Maybe String)]
pathOverride <- [(String, Maybe String)] -> [String] -> IO [(String, Maybe String)]
getExtraPathEnv [(String, Maybe String)]
envOverrides [String]
extraPath
    Maybe [(String, String)]
menv <- [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment ([(String, Maybe String)]
envOverrides [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++ [(String, Maybe String)]
pathOverride)
    (ByteString
_, String
errors, ExitCode
exitCode) <-
      Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode ByteString
-> IO (ByteString, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, String, ExitCode)
rawSystemStdInOut
        Verbosity
verbosity
        String
path
        [String]
args
        Maybe String
mcwd
        Maybe [(String, String)]
menv
        (IOData -> Maybe IOData
forall a. a -> Maybe a
Just IOData
input)
        IODataMode ByteString
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 -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' exited with an error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errors
    where
      input :: IOData
input = IOEncoding -> IOData -> IOData
encodeToIOData IOEncoding
encoding IOData
inputStr

getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity ProgramInvocation
inv = do
  (String
output, String
errors, ExitCode
exitCode) <- Verbosity -> ProgramInvocation -> IO (String, String, 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 -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramInvocation -> String
progInvokePath ProgramInvocation
inv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' exited with an error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errors
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
output

getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString
getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS Verbosity
verbosity ProgramInvocation
inv = do
  (ByteString
output, String
errors, ExitCode
exitCode) <- Verbosity
-> ProgramInvocation
-> IODataMode ByteString
-> IO (ByteString, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors Verbosity
verbosity ProgramInvocation
inv IODataMode ByteString
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 -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramInvocation -> String
progInvokePath ProgramInvocation
inv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' exited with an error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errors
  ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
output

getProgramInvocationOutputAndErrors
  :: Verbosity
  -> ProgramInvocation
  -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity ProgramInvocation
inv = case ProgramInvocation -> IOEncoding
progInvokeOutputEncoding ProgramInvocation
inv of
  IOEncoding
IOEncodingText -> do
    (String
output, String
errors, ExitCode
exitCode) <- Verbosity
-> ProgramInvocation
-> IODataMode String
-> IO (String, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors Verbosity
verbosity ProgramInvocation
inv IODataMode String
IODataModeText
    (String, String, ExitCode) -> IO (String, String, ExitCode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
output, String
errors, ExitCode
exitCode)
  IOEncoding
IOEncodingUTF8 -> do
    (ByteString
output', String
errors, ExitCode
exitCode) <- Verbosity
-> ProgramInvocation
-> IODataMode ByteString
-> IO (ByteString, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors Verbosity
verbosity ProgramInvocation
inv IODataMode ByteString
IODataModeBinary
    (String, String, ExitCode) -> IO (String, String, ExitCode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
normaliseLineEndings (ByteString -> String
fromUTF8LBS ByteString
output'), String
errors, ExitCode
exitCode)

getProgramInvocationIODataAndErrors
  :: KnownIODataMode mode
  => Verbosity
  -> ProgramInvocation
  -> IODataMode mode
  -> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors :: forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = [(String, Maybe String)]
envOverrides
    , progInvokePathEnv :: ProgramInvocation -> [String]
progInvokePathEnv = [String]
extraPath
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
mcwd
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Maybe IOData
minputStr
    , progInvokeInputEncoding :: ProgramInvocation -> IOEncoding
progInvokeInputEncoding = IOEncoding
encoding
    }
  IODataMode mode
mode = do
    [(String, Maybe String)]
pathOverride <- [(String, Maybe String)] -> [String] -> IO [(String, Maybe String)]
getExtraPathEnv [(String, Maybe String)]
envOverrides [String]
extraPath
    Maybe [(String, String)]
menv <- [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment ([(String, Maybe String)]
envOverrides [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++ [(String, Maybe String)]
pathOverride)
    Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, String, ExitCode)
rawSystemStdInOut Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv Maybe IOData
input IODataMode mode
mode
    where
      input :: Maybe IOData
input = IOEncoding -> IOData -> IOData
encodeToIOData IOEncoding
encoding (IOData -> IOData) -> Maybe IOData -> Maybe IOData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe IOData
minputStr

getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)]
getExtraPathEnv :: [(String, Maybe String)] -> [String] -> IO [(String, Maybe String)]
getExtraPathEnv [(String, Maybe String)]
_ [] = [(String, Maybe String)] -> IO [(String, Maybe String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
getExtraPathEnv [(String, Maybe String)]
env [String]
extras = do
  Maybe String
mb_path <- case String -> [(String, Maybe String)] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"PATH" [(String, Maybe String)]
env of
    Just Maybe String
x -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
x
    Maybe (Maybe String)
Nothing -> String -> IO (Maybe String)
lookupEnv String
"PATH"
  let extra :: String
extra = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] [String]
extras
      path' :: String
path' = case Maybe String
mb_path of
        Maybe String
Nothing -> String
extra
        Just String
path -> String
extra String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
searchPathSeparator Char -> String -> String
forall a. a -> [a] -> [a]
: String
path
  [(String, Maybe String)] -> IO [(String, Maybe String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String
"PATH", String -> Maybe String
forall a. a -> Maybe a
Just String
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)]
  -> IO (Maybe [(String, String)])
getEffectiveEnvironment :: [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment [] = Maybe [(String, String)] -> IO (Maybe [(String, String)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, String)]
forall a. Maybe a
Nothing
getEffectiveEnvironment [(String, Maybe String)]
overrides =
  ([(String, String)] -> Maybe [(String, String)])
-> IO [(String, String)] -> IO (Maybe [(String, String)])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(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
. Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map String String -> [(String, String)])
-> ([(String, String)] -> Map String String)
-> [(String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Maybe String)] -> Map String String -> Map String String
forall {t :: * -> *} {k} {a}.
(Foldable t, Ord k) =>
t (k, Maybe a) -> Map k a -> Map k a
apply [(String, Maybe String)]
overrides (Map String String -> Map String String)
-> ([(String, String)] -> Map String String)
-> [(String, String)]
-> Map String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) IO [(String, String)]
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 b a. (b -> a -> b) -> b -> t a -> b
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)
-> [String]
-> [ProgramInvocation]
multiStageProgramInvocation ProgramInvocation
simple (ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final) [String]
args =
  let argSize :: ProgramInvocation -> Int
argSize ProgramInvocation
inv =
        String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ProgramInvocation -> String
progInvokePath ProgramInvocation
inv)
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> String -> Int) -> Int -> [String] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
s String
a -> String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
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 -> [String]
progInvokeArgs ProgramInvocation
inv)
      fixedArgSize :: Int
fixedArgSize = [Int] -> Int
forall a. Ord a => [a] -> a
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 -> [String] -> [[String]]
forall a. Int -> [[a]] -> [[[a]]]
splitChunks Int
chunkSize [String]
args of
        [] -> [ProgramInvocation
simple]
        [[String]
c] -> [ProgramInvocation
simple ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
c]
        ([String]
c : [String]
c2 : [[String]]
cs)
          | ([[String]]
xs, [String]
x) <- NonEmpty [String] -> ([[String]], [String])
forall a. NonEmpty a -> ([a], a)
unsnocNE ([String]
c2 [String] -> [[String]] -> NonEmpty [String]
forall a. a -> [a] -> NonEmpty a
:| [[String]]
cs) ->
              [ProgramInvocation
initial ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
c]
                [ProgramInvocation] -> [ProgramInvocation] -> [ProgramInvocation]
forall a. [a] -> [a] -> [a]
++ [ProgramInvocation
middle ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
c' | [String]
c' <- [[String]]
xs]
                [ProgramInvocation] -> [ProgramInvocation] -> [ProgramInvocation]
forall a. [a] -> [a] -> [a]
++ [ProgramInvocation
final ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
x]
  where
    appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
    ProgramInvocation
inv appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
as = ProgramInvocation
inv{progInvokeArgs = progInvokeArgs inv ++ as}

    splitChunks :: Int -> [[a]] -> [[[a]]]
    splitChunks :: forall a. 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 a. [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 :: forall a. Int -> [[a]] -> ([[a]], [[a]])
chunk Int
len ([a]
s : [[a]]
_) | [a] -> Int
forall 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 = String -> ([[a]], [[a]])
forall a. HasCallStack => String -> a
error String
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' :: forall a. [[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
len Int -> 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 a. [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 :: String
toolong =
      String
"multiStageProgramInvocation: a single program arg is larger "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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