[Git][ghc/ghc][master] Implement Response File support for HPC
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Aug 18 13:23:51 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3e493dfd by Peter Becich at 2022-08-17T08:43:21+01:00
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 at thewallacepack.net>
Fixes #22050
- - - - -
8 changed files:
- libraries/hpc
- utils/hpc/HpcCombine.hs
- utils/hpc/HpcDraft.hs
- utils/hpc/HpcMarkup.hs
- utils/hpc/HpcOverlay.hs
- utils/hpc/HpcReport.hs
- utils/hpc/HpcShowTix.hs
- utils/hpc/Main.hs
Changes:
=====================================
libraries/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 7d400662546a262b64af49b5707db22e20b8b9d9
+Subproject commit 76d1a0473d405e194d0c92a1cbeb6c019bbb57cd
=====================================
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)
-
=====================================
utils/hpc/HpcDraft.hs
=====================================
@@ -142,4 +142,3 @@ findNotTickedFromTree (Node (_, []) children) = findNotTickedFromList children
findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
findNotTickedFromList = concatMap findNotTickedFromTree
-
=====================================
utils/hpc/HpcMarkup.hs
=====================================
@@ -483,4 +483,3 @@ red,green,yellow :: String
red = "#f20913"
green = "#60de51"
yellow = "yellow"
-
=====================================
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
-
-
=====================================
utils/hpc/HpcReport.hs
=====================================
@@ -275,5 +275,3 @@ report_options
. resetHpcDirsOpt
. xmlOutputOpt
. verbosityOpt
-
-
=====================================
utils/hpc/HpcShowTix.hs
=====================================
@@ -61,4 +61,3 @@ showtix_main flags (prog:modNames) = do
]
return ()
-
=====================================
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'
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e493dfd4db4b61ffc3f1faf7e38663118473d99
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e493dfd4db4b61ffc3f1faf7e38663118473d99
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220818/c2def05b/attachment-0001.html>
More information about the ghc-commits
mailing list