{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

----------------------------------------------------------------------------

----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Program.ResponseFile
-- Copyright   :  (c) Sergey Vinokurov 2017
-- License     :  BSD3-style
--
-- Maintainer  :  cabal-devel@haskell.org
-- Created     :  23 July 2017
module Distribution.Simple.Program.ResponseFile (withResponseFile) where

import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding)
import Prelude ()

import Distribution.Compat.Prelude
import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx)
import Distribution.Utils.Path
import Distribution.Verbosity

withResponseFile
  :: Verbosity
  -> TempFileOptions
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ Working directory
  -> SymbolicPath Pkg (Dir Response)
  -- ^ Directory to create response file in.
  -> String
  -- ^ Template for response file name.
  -> Maybe TextEncoding
  -- ^ Encoding to use for response file contents.
  -> [String]
  -- ^ Arguments to put into response file.
  -> (FilePath -> IO a)
  -> IO a
withResponseFile :: forall a.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> String
-> Maybe TextEncoding
-> [String]
-> (String -> IO a)
-> IO a
withResponseFile Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Response)
responseDir String
fileNameTemplate Maybe TextEncoding
encoding [String]
arguments String -> IO a
f =
  TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> String
-> (SymbolicPath Pkg 'File -> Handle -> IO a)
-> IO a
forall a tmpDir.
TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir)
-> String
-> (SymbolicPath Pkg 'File -> Handle -> IO a)
-> IO a
withTempFileEx TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Response)
responseDir String
fileNameTemplate ((SymbolicPath Pkg 'File -> Handle -> IO a) -> IO a)
-> (SymbolicPath Pkg 'File -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SymbolicPath Pkg 'File
responsePath Handle
hf -> do
    let responseFileName :: String
responseFileName = SymbolicPath Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg 'File
responsePath
    (TextEncoding -> IO ()) -> Maybe TextEncoding -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hf) Maybe TextEncoding
encoding
    let responseContents :: String
responseContents =
          [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
escapeResponseFileArg ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
              [String]
arguments
    Handle -> String -> IO ()
hPutStr Handle
hf String
responseContents
    Handle -> IO ()
hClose Handle
hf
    Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
responseFileName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" contents: <<<"
    Verbosity -> String -> IO ()
debug Verbosity
verbosity String
responseContents
    Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
">>> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
responseFileName
    String -> IO a
f String
responseFileName

-- Support a gcc-like response file syntax.  Each separate
-- argument and its possible parameter(s), will be separated in the
-- response file by an actual newline; all other whitespace,
-- single quotes, double quotes, and the character used for escaping
-- (backslash) are escaped.  The called program will need to do a similar
-- inverse operation to de-escape and re-constitute the argument list.
escapeResponseFileArg :: String -> String
escapeResponseFileArg :: String -> String
escapeResponseFileArg = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Char -> String) -> String -> String -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' String -> Char -> String
escape []
  where
    escape :: String -> Char -> String
    escape :: String -> Char -> String
escape String
cs Char
c =
      case Char
c of
        Char
'\\' -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
        Char
'\'' -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
        Char
'"' -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
        Char
_
          | Char -> Bool
isSpace Char
c -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
          | Bool
otherwise -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs