Implement Response File support for HPC

This is an improvement to HPC authored by Richard Wallace
(https://github.com/purefn) and myself. I have received permission from
him to attempt to upstream it. This improvement was originally
implemented as a patch to HPC via input-output-hk/haskell.nix:
https://github.com/input-output-hk/haskell.nix/pull/1464

Paraphrasing Richard, HPC currently requires all inputs as command line arguments.
With large projects this can result in an argument list too long error.
I have only seen this error in Nix, but I assume it can occur is a plain Unix environment.

This MR adds the standard response file syntax support to HPC. For
example you can now pass a file to the command line which contains the
arguments.

```
hpc @response_file_1 @response_file_2 ...

The contents of a Response File must have this format:
COMMAND ...

example:
report my_library.tix --include=ModuleA --include=ModuleB
```

Updates hpc submodule

Co-authored-by:  Richard Wallace <rwallace@thewallacepack.net>

Fixes #22050

7 files changed, 85 insertions, 16 deletions

diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs
index db6ae9c948..864b1054d0 100644
--- a/utils/hpc/HpcCombine.hs
+++ b/utils/hpc/HpcCombine.hs
@@ -195,4 +195,3 @@ instance Strict Tix where
 instance Strict TixModule where
   strict (TixModule m1 p1 i1 t1) =
             ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
-
diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs
index 975dbf4f65..f93e397353 100644
--- a/utils/hpc/HpcDraft.hs
+++ b/utils/hpc/HpcDraft.hs
@@ -142,4 +142,3 @@ findNotTickedFromTree (Node (_, []) children) = findNotTickedFromList children
 
 findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
 findNotTickedFromList = concatMap findNotTickedFromTree
-
diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs
index 1d5efcf6d6..d156f261cb 100644
--- a/utils/hpc/HpcMarkup.hs
+++ b/utils/hpc/HpcMarkup.hs
@@ -483,4 +483,3 @@ red,green,yellow :: String
 red    = "#f20913"
 green  = "#60de51"
 yellow = "yellow"
-
diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs
index c4f8e96bf4..44ac6d065a 100644
--- a/utils/hpc/HpcOverlay.hs
+++ b/utils/hpc/HpcOverlay.hs
@@ -155,5 +155,3 @@ addParentToTree path (Node (pos,a) children) =
 
 addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a],[a])]
 addParentToList path nodes = map (addParentToTree path) nodes
-
-
diff --git a/utils/hpc/HpcReport.hs b/utils/hpc/HpcReport.hs
index 4c975be425..ee5924fcd4 100644
--- a/utils/hpc/HpcReport.hs
+++ b/utils/hpc/HpcReport.hs
@@ -275,5 +275,3 @@ report_options
         . resetHpcDirsOpt
         . xmlOutputOpt
         . verbosityOpt
-
-
diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs
index f0c628e422..551ed88a58 100644
--- a/utils/hpc/HpcShowTix.hs
+++ b/utils/hpc/HpcShowTix.hs
@@ -61,4 +61,3 @@ showtix_main flags (prog:modNames) = do
                  ]
 
        return ()
-
diff --git a/utils/hpc/Main.hs b/utils/hpc/Main.hs
index 3f1813f243..f7617ec677 100644
--- a/utils/hpc/Main.hs
+++ b/utils/hpc/Main.hs
@@ -1,10 +1,17 @@
+{-# LANGUAGE ScopedTypeVariables, TupleSections #-}
 -- (c) 2007 Andy Gill
 
 -- Main driver for Hpc
+import Control.Monad (forM, forM_, when)
+import Data.Bifunctor (bimap)
+import Data.List (intercalate, partition, uncons)
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Maybe (catMaybes, isJust)
 import Data.Version
 import System.Environment
 import System.Exit
 import System.Console.GetOpt
+import System.Directory (doesPathExist)
 
 import HpcFlags
 import HpcReport
@@ -16,7 +23,7 @@ import HpcOverlay
 import Paths_hpc_bin
 
 helpList :: IO ()
-helpList =
+helpList = do
      putStrLn $
            "Usage: hpc COMMAND ...\n\n" ++
            section "Commands" help ++
@@ -25,6 +32,15 @@ helpList =
            section "Coverage Overlays" overlays ++
            section "Others" other ++
            ""
+     putStrLn ""
+     putStrLn "or: hpc @response_file_1 @response_file_2 ..."
+     putStrLn ""
+     putStrLn "The contents of a Response File must have this format:"
+     putStrLn "COMMAND ..."
+     putStrLn ""
+     putStrLn "example:"
+     putStrLn "report my_library.tix --include=ModuleA \\"
+     putStrLn "--include=ModuleB"
   where
     help       = ["help"]
     reporting  = ["report","markup"]
@@ -47,13 +63,74 @@ section msg cmds = msg ++ ":\n"
 
 dispatch :: [String] -> IO ()
 dispatch [] = do
-             helpList
-             exitWith ExitSuccess
+    helpList
+    exitWith ExitSuccess
 dispatch (txt:args0) = do
-     case lookup txt hooks' of
-       Just plugin -> parse plugin args0
-       _ -> parse help_plugin (txt:args0)
+    case lookup txt hooks' of
+      Just plugin -> parse plugin args0
+      _ -> case getResponseFileName txt of
+        Nothing -> parse help_plugin (txt:args0)
+        Just firstResponseFileName -> do
+          let
+            (responseFileNames', nonResponseFileNames) = partitionFileNames args0
+          -- if arguments are combination of Response Files and non-Response Files, exit with error
+          when (length nonResponseFileNames > 0) $ do
+            let
+            putStrLn $ "First argument '" <> txt <> "' is a Response File, " <>
+              "followed by non-Response File(s): '" <> intercalate "', '" nonResponseFileNames <> "'"
+            putStrLn $ "When first argument is a Response File, " <>
+              "all arguments should be Response Files."
+            exitFailure
+          let
+            responseFileNames :: NonEmpty FilePath
+            responseFileNames = firstResponseFileName :| responseFileNames'
+
+          forM_ responseFileNames $ \responseFileName -> do
+            exists <- doesPathExist responseFileName
+            when (not exists) $ do
+              putStrLn $ "Response File '" <> responseFileName <> "' does not exist"
+              exitFailure
+
+          -- read all Response Files
+          responseFileNamesAndText :: NonEmpty (FilePath, String) <-
+            forM responseFileNames $ \responseFileName ->
+              fmap (responseFileName, ) (readFile responseFileName)
+          forM_ responseFileNamesAndText $ \(responseFileName, responseFileText) ->
+            -- parse first word of Response File, which should be a command
+            case uncons $ words responseFileText of
+              Nothing -> do
+                putStrLn $ "Response File '" <> responseFileName <> "' has no command"
+                exitFailure
+              Just (responseFileCommand, args1) -> case lookup responseFileCommand hooks' of
+                -- check command for validity
+                -- It is important than a Response File cannot specify another Response File;
+                -- this is prevented
+                Nothing -> do
+                  putStrLn $ "Response File '" <> responseFileName <>
+                    "' command '" <> responseFileCommand <> "' invalid"
+                  exitFailure
+                Just plugin -> do
+                  putStrLn $ "Response File '" <> responseFileName <> "':"
+                  parse plugin args1
+
   where
+     getResponseFileName :: String -> Maybe FilePath
+     getResponseFileName s = do
+       (firstChar, filename) <- uncons s
+       if firstChar == '@'
+         then pure filename
+         else Nothing
+
+     -- first member of tuple is list of Response File names,
+     -- second member of tuple is list of all other arguments
+     partitionFileNames :: [String] -> ([FilePath], [String])
+     partitionFileNames xs = let
+       hasFileName :: [(String, Maybe FilePath)]
+       hasFileName = fmap (\x -> (x, getResponseFileName x)) xs
+       (fileNames, nonFileNames) :: ([Maybe FilePath], [String]) =
+         bimap (fmap snd) (fmap fst) $ partition (isJust . snd) hasFileName
+       in (catMaybes fileNames, nonFileNames)
+
      parse plugin args =
               case getOpt Permute (options plugin []) args of
                 (_,_,errs) | not (null errs)
@@ -66,7 +143,7 @@ dispatch (txt:args0) = do
                            exitFailure
                 (o,ns,_) -> do
                          let flags = final_flags plugin
-                                   $ foldr (.) id o
+                                   . foldr (.) id o
                                    $ init_flags plugin
                          implementation plugin flags ns
 
@@ -112,7 +189,7 @@ help_main _ [] = do
 help_main _ (sub_txt:_) = do
     case lookup sub_txt hooks' of
       Nothing -> do
-          putStrLn $ "no such hpc command : " ++ sub_txt
+          putStrLn $ "no such HPC command: " <> sub_txt
           exitFailure
       Just plugin' -> do
           command_usage plugin'