diff --git a/Compat/ResponseFile.hs b/Compat/ResponseFile.hs new file mode 100644 index 0000000..eb8e2df --- /dev/null +++ b/Compat/ResponseFile.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- taken from base-4.12.0.0's "GHC.ResponseFile" + +module Compat.ResponseFile ( getArgsWithResponseFiles ) where + +#if MIN_VERSION_base(4,12,0) + +import GHC.ResponseFile (getArgsWithResponseFiles) + +#else + +import Control.Exception +import Data.Char (isSpace) +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 = getArgs >>= 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" == escapeArgs "hello \"world\"" +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | 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 = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `Control.Exception.catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +#endif diff --git a/Main.hs b/Main.hs index c3f63b6..9935eee 100644 --- a/Main.hs +++ b/Main.hs @@ -44,13 +44,9 @@ import Data.Version ( showVersion ) import System.Environment ( getExecutablePath ) import System.FilePath ( takeDirectory, () ) #endif -#if MIN_VERSION_base(4,12,0) -import GHC.ResponseFile ( getArgsWithResponseFiles ) -#else -import System.Environment ( getArgs ) -#endif import Common +import Compat.ResponseFile ( getArgsWithResponseFiles ) import CrossCodegen import DirectCodegen import Flags @@ -79,11 +75,7 @@ main = do prog <- getProgramName let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n" usage = usageInfo header options -#if MIN_VERSION_base(4,12,0) args <- getArgsWithResponseFiles -#else - args <- getArgs -#endif let (fs, files, errs) = getOpt Permute options args let mode = foldl (.) id fs emptyMode case mode of diff --git a/changelog.md b/changelog.md index 2013279..b1061c5 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +## 0.68.4.1 + + - Support response files regardless of which GHC `hsc2hs` was compiled + with ([#15758](https://ghc.haskell.org/trac/ghc/ticket/15758)) + ## 0.68.4 - Add support to read command line arguments supplied via response files diff --git a/hsc2hs.cabal b/hsc2hs.cabal index e3ff380..d08cd9e 100644 --- a/hsc2hs.cabal +++ b/hsc2hs.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 Name: hsc2hs -Version: 0.68.4 +Version: 0.68.4.1 Copyright: 2000, Marcin Kowalczyk License: BSD3 @@ -51,6 +51,7 @@ Executable hsc2hs HSCParser ATTParser UtilsCodegen + Compat.ResponseFile Paths_hsc2hs Other-Extensions: CPP, NoMonomorphismRestriction