Cabal/src/Distribution/Compat/ResponseFile.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -- Compatibility layer for GHC.ResponseFile
   6 -- Implementation from base 4.12.0 is used.
   7 -- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE
   8 module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where
   9
  10 import Distribution.Compat.Prelude
  11 import Prelude ()
  12
  13 import System.FilePath
  14 import System.IO (hPutStrLn, stderr)
  15 import System.IO.Error
  16
  17 #if MIN_VERSION_base(4,12,0)
  18 import GHC.ResponseFile (unescapeArgs, escapeArgs)
  19 #else
  20
  21 unescapeArgs :: String -> [String]
  22 unescapeArgs = filter (not . null) . unescape
  23
  24 data Quoting = NoneQ | SngQ | DblQ
  25
  26 unescape :: String -> [String]
  27 unescape args = reverse . map reverse $ go args NoneQ False [] []
  28     where
  29       -- n.b., the order of these cases matters; these are cribbed from gcc
  30       -- case 1: end of input
  31       go []     _q    _bs   a as = a:as
  32       -- case 2: back-slash escape in progress
  33       go (c:cs) q     True  a as = go cs q     False (c:a) as
  34       -- case 3: no back-slash escape in progress, but got a back-slash
  35       go (c:cs) q     False a as
  36         | '\\' == c              = go cs q     True  a     as
  37       -- case 4: single-quote escaping in progress
  38       go (c:cs) SngQ  False a as
  39         | '\'' == c              = go cs NoneQ False a     as
  40         | otherwise              = go cs SngQ  False (c:a) as
  41       -- case 5: double-quote escaping in progress
  42       go (c:cs) DblQ  False a as
  43         | '"' == c               = go cs NoneQ False a     as
  44         | otherwise              = go cs DblQ  False (c:a) as
  45       -- case 6: no escaping is in progress
  46       go (c:cs) NoneQ False a as
  47         | isSpace c              = go cs NoneQ False []    (a:as)
  48         | '\'' == c              = go cs SngQ  False a     as
  49         | '"'  == c              = go cs DblQ  False a     as
  50         | otherwise              = go cs NoneQ False (c:a) as
  51
  52 escapeArgs :: [String] -> String
  53 escapeArgs = unlines . map escapeArg
  54
  55 escapeArg :: String -> String
  56 escapeArg = reverse . foldl' escape []
  57
  58 escape :: String -> Char -> String
  59 escape cs c
  60   |    isSpace c
  61     || '\\' == c
  62     || '\'' == c
  63     || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
  64   | otherwise    = c:cs
  65
  66 #endif
  67
  68 -- | The arg file / response file parser.
  69 --
  70 -- This is not a well-documented capability, and is a bit eccentric
  71 -- (try @cabal \@foo \@bar@ to see what that does), but is crucial
  72 -- for allowing complex arguments to cabal and cabal-install when
  73 -- using command prompts with strongly-limited argument length.
  74 expandResponse :: [String] -> IO [String]
  75 expandResponse = go recursionLimit "."
  76   where
  77     recursionLimit = 100
  78
  79     go :: Int -> FilePath -> [String] -> IO [String]
  80     go n dir
  81       | n >= 0 = fmap concat . traverse (expand n dir)
  82       | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure
  83
  84     expand :: Int -> FilePath -> String -> IO [String]
  85     expand n dir arg@('@' : f) = readRecursively n (dir </> f) `catchIOError` const (print "?" >> return [arg])
  86     expand _n _dir x = return [x]
  87
  88     readRecursively :: Int -> FilePath -> IO [String]
  89     readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f