-----------------------------------------------------------------------------
-- |
-- 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,

  ) where

import Distribution.Simple.Program.Types
         ( ConfiguredProgram(..), programPath )
import Distribution.Simple.Utils
         ( die, rawSystemExit, rawSystemStdInOut
         , toUTF8, fromUTF8, normaliseLineEndings )
import Distribution.Verbosity
         ( Verbosity )

import Data.List
         ( foldl', unfoldr )
import Control.Monad
         ( when )
import System.Exit
         ( ExitCode(..) )

-- | 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 progInvokeOutputEncoding :: IOEncodingProgramInvocation = ProgramInvocation {
       progInvokePath  :: FilePath,
       progInvokeArgs  :: [String],
       progInvokeEnv   :: [(String, String)],
       progInvokeCwd   :: Maybe FilePath,
       progInvokeInput :: Maybe String,
       progInvokeInputEncoding  :: IOEncoding,
       progInvokeOutputEncoding :: IOEncoding
     }

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

emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation =
  ProgramInvocation {
    progInvokePath  = "",
    progInvokeArgs  = [] :: [a][],
    progInvokeEnv   = [] :: [a][],
    progInvokeCwd   = Nothing :: Maybe aNothing,
    progInvokeInput = Nothing :: Maybe aNothing,
    progInvokeInputEncoding  = IOEncodingText :: IOEncodingIOEncodingText,
    progInvokeOutputEncoding = IOEncodingText :: IOEncodingIOEncodingText
  }

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

programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation prog args =
  emptyProgramInvocation :: ProgramInvocationemptyProgramInvocation {
    progInvokePath = programPath :: ConfiguredProgram -> FilePathprogramPath prog :: ConfiguredProgramprog,
    progInvokeArgs = programDefaultArgs :: ConfiguredProgram -> [String]programDefaultArgs prog :: ConfiguredProgramprog
                  (++) :: [a] -> [a] -> [a]++ args :: [String]args
                  (++) :: [a] -> [a] -> [a]++ programOverrideArgs :: ConfiguredProgram -> [String]programOverrideArgs prog :: ConfiguredProgramprog
  }


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

runProgramInvocation verbosity
  ProgramInvocation {
    progInvokePath  = path,
    progInvokeArgs  = args,
    progInvokeEnv   = [],
    progInvokeCwd   = Nothing,
    progInvokeInput = Just inputStr,
    progInvokeInputEncoding = encoding
  } = do
    (_, errors, exitCode) <- rawSystemStdInOut ::
  Verbosity
  -> FilePath
  -> [String]
  -> Maybe (String, Bool)
  -> Bool
  -> IO (String, String, ExitCode)rawSystemStdInOut verbosity :: Verbosityverbosity
                                    path :: FilePathpath args :: [String]args
                                    (Just :: a -> Maybe aJust input :: (String, Bool)input) False :: BoolFalse
    when :: Monad m => Bool -> m () -> m ()when (exitCode :: ExitCodeexitCode (/=) :: Eq a => a -> a -> Bool/= ExitSuccess :: ExitCodeExitSuccess) ($) :: (a -> b) -> a -> b$
      die :: String -> IO adie errors :: Stringerrors
  where
    input = case encoding :: IOEncodingencoding of
              IOEncodingText -> (inputStr :: StringinputStr, False :: BoolFalse)
              IOEncodingUTF8 -> (toUTF8 :: String -> StringtoUTF8 inputStr :: StringinputStr, True :: BoolTrue) -- use binary mode for utf8

runProgramInvocation _ _ =
   die :: String -> IO adie "runProgramInvocation: not yet implemented for this form of invocation"


getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput verbosity
  ProgramInvocation {
    progInvokePath  = path,
    progInvokeArgs  = args,
    progInvokeEnv   = [],
    progInvokeCwd   = Nothing,
    progInvokeInput = Nothing,
    progInvokeOutputEncoding = encoding
  } = do
  let utf8 = case encoding :: IOEncodingencoding of IOEncodingUTF8 -> True :: BoolTrue; _ -> False :: BoolFalse
      decode | utf8 :: Boolutf8      = fromUTF8 :: String -> StringfromUTF8 (.) :: (b -> c) -> (a -> b) -> a -> c. normaliseLineEndings :: String -> StringnormaliseLineEndings
             | otherwise :: Boolotherwise = id :: a -> aid
  (output, errors, exitCode) <- rawSystemStdInOut ::
  Verbosity
  -> FilePath
  -> [String]
  -> Maybe (String, Bool)
  -> Bool
  -> IO (String, String, ExitCode)rawSystemStdInOut verbosity :: Verbosityverbosity
                                  path :: FilePathpath args :: [String]args
                                  Nothing :: Maybe aNothing utf8 :: Boolutf8
  when :: Monad m => Bool -> m () -> m ()when (exitCode :: ExitCodeexitCode (/=) :: Eq a => a -> a -> Bool/= ExitSuccess :: ExitCodeExitSuccess) ($) :: (a -> b) -> a -> b$
    die :: String -> IO adie errors :: Stringerrors
  return :: Monad m => forall a. a -> m areturn (decode :: String -> Stringdecode output :: Stringoutput)


getProgramInvocationOutput _ _ =
   die :: String -> IO adie "getProgramInvocationOutput: not yet implemented for this form of invocation"


-- | 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 simple (initial, middle, final) args =

  let argSize inv  = length :: [a] -> Intlength (progInvokePath :: ProgramInvocation -> FilePathprogInvokePath inv :: ProgramInvocationinv)
                   (+) :: Num a => a -> a -> a+ foldl' :: (a -> b -> a) -> a -> [b] -> afoldl' (\s a -> length :: [a] -> Intlength a :: [Char]a (+) :: Num a => a -> a -> a+ 1 (+) :: Num a => a -> a -> a+ s :: [[a]]s) 1 (progInvokeArgs :: ProgramInvocation -> [String]progInvokeArgs inv :: ProgramInvocationinv)
      fixedArgSize = maximum :: Ord a => [a] -> amaximum (map :: (a -> b) -> [a] -> [b]map argSize :: ProgramInvocation -> IntargSize [simple :: ProgramInvocationsimple, initial :: ProgramInvocationinitial, middle :: ProgramInvocationmiddle, final :: ProgramInvocationfinal])
      chunkSize    = maxCommandLineSize :: IntmaxCommandLineSize (-) :: Num a => a -> a -> a- fixedArgSize :: IntfixedArgSize

   in case splitChunks :: Int -> [[a]] -> [[[a]]]splitChunks chunkSize :: IntchunkSize args :: [String]args of
        []     -> [ simple :: ProgramInvocationsimple ]

        [c]    -> [ simple :: ProgramInvocationsimple  appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation`appendArgs` c :: [[Char]]c ]

        [c,c'] -> [ initial :: ProgramInvocationinitial appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation`appendArgs` c :: [[Char]]c ]
               (++) :: [a] -> [a] -> [a]++ [ final :: ProgramInvocationfinal   appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation`appendArgs` c' :: [[Char]]c']

        (c:cs) -> [ initial :: ProgramInvocationinitial appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation`appendArgs` c :: [[Char]]c ]
               (++) :: [a] -> [a] -> [a]++ [ middle :: ProgramInvocationmiddle  appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation`appendArgs` c' :: [[Char]]c'| c' <- init :: [a] -> [a]init cs :: [[[Char]]]cs ]
               (++) :: [a] -> [a] -> [a]++ [ final :: ProgramInvocationfinal   appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation`appendArgs` c' :: [[Char]]c'| let c' = last :: [a] -> alast cs :: [[[Char]]]cs ]

  where
    inv `appendArgs` as = inv :: ProgramInvocationinv { progInvokeArgs = progInvokeArgs :: ProgramInvocation -> [String]progInvokeArgs inv :: ProgramInvocationinv (++) :: [a] -> [a] -> [a]++ as :: [String]as }

    splitChunks len = unfoldr :: (b -> Maybe (a, b)) -> b -> [a]unfoldr ($) :: (a -> b) -> a -> b$ \s ->
      if null :: [a] -> Boolnull s :: [[a]]s then Nothing :: Maybe aNothing
                else Just :: a -> Maybe aJust (chunk :: Int -> [[a]] -> ([[a]], [[a]])chunk len :: Intlen s :: [[a]]s)

    chunk len (s:_) | length :: [a] -> Intlength s :: [[a]]s (>=) :: Ord a => a -> a -> Bool>= len :: Intlen = error :: [Char] -> aerror toolong :: [Char]toolong
    chunk len ss    = chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])chunk' [] :: [a][] len :: Intlen ss :: [[a]]ss

    chunk' acc _   []     = (reverse :: [a] -> [a]reverse acc :: [[a]]acc,[] :: [a][])
    chunk' acc len (s:ss)
      | len' :: Intlen' (<) :: Ord a => a -> a -> Bool< len :: Intlen = chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])chunk' (s :: [[a]]s(:) :: a -> [a] -> [a]:acc :: [[a]]acc) (len :: Intlen(-) :: Num a => a -> a -> a-len' :: Intlen'(-) :: Num a => a -> a -> a-1) ss :: [[a]]ss
      | otherwise :: Boolotherwise  = (reverse :: [a] -> [a]reverse acc :: [[a]]acc, s :: [[a]]s(:) :: a -> [a] -> [a]:ss :: [[a]]ss)
      where len' = length :: [a] -> Intlength s :: [[a]]s

    toolong = "multiStageProgramInvocation: a single program arg is larger "
           (++) :: [a] -> [a] -> [a]++ "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 = 30 (*) :: Num a => a -> a -> a* 1024