{-# 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.Errors
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 -> CabalException -> IO ()
forall a. HasCallStack => Verbosity -> CabalException -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> String -> CabalException
RunProgramInvocationException String
path 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 -> CabalException -> IO ()
forall a. HasCallStack => Verbosity -> CabalException -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> CabalException
GetProgramInvocationLBSException (ProgramInvocation -> String
progInvokePath ProgramInvocation
inv) 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