{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.ResponseFile
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  portable
--
-- GCC style response files.
--
-- @since 4.12.0.0
----------------------------------------------------------------------------

-- Migrated from Haddock.

module GHC.ResponseFile (
    getArgsWithResponseFiles,
    unescapeArgs,
    escapeArgs,
    expandResponse
  ) where

import Control.Exception
import Data.Char          (isSpace)
import Data.Foldable      (foldl')
import System.Environment (getArgs)
import System.Exit        (exitFailure)
import System.IO

{-|
Like 'getArgs', but can also read arguments supplied via response files.


For example, consider a program @foo@:

@
main :: IO ()
main = do
  args <- getArgsWithResponseFiles
  putStrLn (show args)
@


And a response file @args.txt@:

@
--one 1
--\'two\' 2
--"three" 3
@

Then the result of invoking @foo@ with @args.txt@ is:

> > ./foo @args.txt
> ["--one","1","--two","2","--three","3"]

-}
getArgsWithResponseFiles :: IO [String]
getArgsWithResponseFiles :: IO [String]
getArgsWithResponseFiles = IO [String]
getArgs IO [String] -> ([String] -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO [String]
expandResponse

-- | Given a string of concatenated strings, separate each by removing
-- a layer of /quoting/ and\/or /escaping/ of certain characters.
--
-- These characters are: any whitespace, single quote, double quote,
-- and the backslash character.  The backslash character always
-- escapes (i.e., passes through without further consideration) the
-- character which follows.  Characters can also be escaped in blocks
-- by quoting (i.e., surrounding the blocks with matching pairs of
-- either single- or double-quotes which are not themselves escaped).
--
-- Any whitespace which appears outside of either of the quoting and
-- escaping mechanisms, is interpreted as having been added by this
-- special concatenation process to designate where the boundaries
-- are between the original, un-concatenated list of strings.  These
-- added whitespace characters are removed from the output.
--
-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""]
unescapeArgs :: String -> [String]
unescapeArgs :: String -> [String]
unescapeArgs = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
unescape

-- | Given a list of strings, concatenate them into a single string
-- with escaping of certain characters, and the addition of a newline
-- between each string.  The escaping is done by adding a single
-- backslash character before any whitespace, single quote, double
-- quote, or backslash character, so this escaping character must be
-- removed.  Unescaped whitespace (in this case, newline) is part
-- of this "transport" format to indicate the end of the previous
-- string and the start of a new string.
--
-- While 'unescapeArgs' allows using quoting (i.e., convenient
-- escaping of many characters) by having matching sets of single- or
-- double-quotes,'escapeArgs' does not use the quoting mechasnism,
-- and thus will always escape any whitespace, quotes, and
-- backslashes.
--
-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n"
escapeArgs :: [String] -> String
escapeArgs :: [String] -> String
escapeArgs = [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
escapeArg

-- | Arguments which look like @\@foo@ will be replaced with the
-- contents of file @foo@. A gcc-like syntax for response files arguments
-- is expected.  This must re-constitute the argument list by doing an
-- inverse of the escaping mechanism done by the calling-program side.
--
-- We quit if the file is not found or reading somehow fails.
-- (A convenience routine for haddock or possibly other clients)
expandResponse :: [String] -> IO [String]
expandResponse :: [String] -> IO [String]
expandResponse = ([[String]] -> [String]) -> IO [[String]] -> IO [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]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[String]] -> IO [String])
-> ([String] -> IO [[String]]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO [String]
expand
  where
    expand :: String -> IO [String]
    expand :: String -> IO [String]
expand (Char
'@':String
f) = String -> IO String
readFileExc String
f IO String -> (String -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> (String -> [String]) -> String -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
unescapeArgs
    expand String
x = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
x]

    readFileExc :: String -> IO String
readFileExc String
f =
      String -> IO String
readFile String
f IO String -> (IOException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error while expanding response file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e
        IO String
forall a. IO a
exitFailure

data Quoting = NoneQ | SngQ | DblQ

unescape :: String -> [String]
unescape :: String -> [String]
unescape String
args = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Quoting -> Bool -> String -> [String] -> [String]
go String
args Quoting
NoneQ Bool
False [] []
    where
      -- n.b., the order of these cases matters; these are cribbed from gcc
      -- case 1: end of input
      go :: String -> Quoting -> Bool -> String -> [String] -> [String]
go []     Quoting
_q    Bool
_bs   String
a [String]
as = String
aString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
as
      -- case 2: back-slash escape in progress
      go (Char
c:String
cs) Quoting
q     Bool
True  String
a [String]
as = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
q     Bool
False (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) [String]
as
      -- case 3: no back-slash escape in progress, but got a back-slash
      go (Char
c:String
cs) Quoting
q     Bool
False String
a [String]
as
        | Char
'\\' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
q     Bool
True  String
a     [String]
as
      -- case 4: single-quote escaping in progress
      go (Char
c:String
cs) Quoting
SngQ  Bool
False String
a [String]
as
        | Char
'\'' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
NoneQ Bool
False String
a     [String]
as
        | Bool
otherwise              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
SngQ  Bool
False (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) [String]
as
      -- case 5: double-quote escaping in progress
      go (Char
c:String
cs) Quoting
DblQ  Bool
False String
a [String]
as
        | Char
'"' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c               = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
NoneQ Bool
False String
a     [String]
as
        | Bool
otherwise              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
DblQ  Bool
False (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) [String]
as
      -- case 6: no escaping is in progress
      go (Char
c:String
cs) Quoting
NoneQ Bool
False String
a [String]
as
        | Char -> Bool
isSpace Char
c              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
NoneQ Bool
False []    (String
aString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
as)
        | Char
'\'' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
SngQ  Bool
False String
a     [String]
as
        | Char
'"'  Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
DblQ  Bool
False String
a     [String]
as
        | Bool
otherwise              = String -> Quoting -> Bool -> String -> [String] -> [String]
go String
cs Quoting
NoneQ Bool
False (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
a) [String]
as

escapeArg :: String -> String
escapeArg :: String -> String
escapeArg = 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 []

escape :: String -> Char -> String
escape :: String -> Char -> String
escape String
cs Char
c
  |    Char -> Bool
isSpace Char
c
    Bool -> Bool -> Bool
|| Char
'\\' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
    Bool -> Bool -> Bool
|| Char
'\'' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
    Bool -> Bool -> Bool
|| Char
'"'  Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:String
cs -- n.b., our caller must reverse the result
  | Bool
otherwise    = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs