|
| 1 | +diff --git a/utils/hpc/Main.hs b/utils/hpc/Main.hs |
| 2 | +index 3f1813f2430f8a69dc8c334621661fdc03157c21..f7617ec6775351cbc3c149a433c4cbe5b47fb4d2 100644 |
| 3 | +--- a/utils/hpc/Main.hs |
| 4 | ++++ b/utils/hpc/Main.hs |
| 5 | +@@ -1,10 +1,17 @@ |
| 6 | ++{-# LANGUAGE ScopedTypeVariables, TupleSections #-} |
| 7 | + -- (c) 2007 Andy Gill |
| 8 | + |
| 9 | + -- Main driver for Hpc |
| 10 | ++import Control.Monad (forM, forM_, when) |
| 11 | ++import Data.Bifunctor (bimap) |
| 12 | ++import Data.List (intercalate, partition, uncons) |
| 13 | ++import Data.List.NonEmpty (NonEmpty((:|))) |
| 14 | ++import Data.Maybe (catMaybes, isJust) |
| 15 | + import Data.Version |
| 16 | + import System.Environment |
| 17 | + import System.Exit |
| 18 | + import System.Console.GetOpt |
| 19 | ++import System.Directory (doesPathExist) |
| 20 | + |
| 21 | + import HpcFlags |
| 22 | + import HpcReport |
| 23 | +@@ -16,7 +23,7 @@ import HpcOverlay |
| 24 | + import Paths_hpc_bin |
| 25 | + |
| 26 | + helpList :: IO () |
| 27 | +-helpList = |
| 28 | ++helpList = do |
| 29 | + putStrLn $ |
| 30 | + "Usage: hpc COMMAND ...\n\n" ++ |
| 31 | + section "Commands" help ++ |
| 32 | +@@ -25,6 +32,15 @@ helpList = |
| 33 | + section "Coverage Overlays" overlays ++ |
| 34 | + section "Others" other ++ |
| 35 | + "" |
| 36 | ++ putStrLn "" |
| 37 | ++ putStrLn "or: hpc @response_file_1 @response_file_2 ..." |
| 38 | ++ putStrLn "" |
| 39 | ++ putStrLn "The contents of a Response File must have this format:" |
| 40 | ++ putStrLn "COMMAND ..." |
| 41 | ++ putStrLn "" |
| 42 | ++ putStrLn "example:" |
| 43 | ++ putStrLn "report my_library.tix --include=ModuleA \\" |
| 44 | ++ putStrLn "--include=ModuleB" |
| 45 | + where |
| 46 | + help = ["help"] |
| 47 | + reporting = ["report","markup"] |
| 48 | +@@ -47,13 +63,74 @@ section msg cmds = msg ++ ":\n" |
| 49 | + |
| 50 | + dispatch :: [String] -> IO () |
| 51 | + dispatch [] = do |
| 52 | +- helpList |
| 53 | +- exitWith ExitSuccess |
| 54 | ++ helpList |
| 55 | ++ exitWith ExitSuccess |
| 56 | + dispatch (txt:args0) = do |
| 57 | +- case lookup txt hooks' of |
| 58 | +- Just plugin -> parse plugin args0 |
| 59 | +- _ -> parse help_plugin (txt:args0) |
| 60 | ++ case lookup txt hooks' of |
| 61 | ++ Just plugin -> parse plugin args0 |
| 62 | ++ _ -> case getResponseFileName txt of |
| 63 | ++ Nothing -> parse help_plugin (txt:args0) |
| 64 | ++ Just firstResponseFileName -> do |
| 65 | ++ let |
| 66 | ++ (responseFileNames', nonResponseFileNames) = partitionFileNames args0 |
| 67 | ++ -- if arguments are combination of Response Files and non-Response Files, exit with error |
| 68 | ++ when (length nonResponseFileNames > 0) $ do |
| 69 | ++ let |
| 70 | ++ putStrLn $ "First argument '" <> txt <> "' is a Response File, " <> |
| 71 | ++ "followed by non-Response File(s): '" <> intercalate "', '" nonResponseFileNames <> "'" |
| 72 | ++ putStrLn $ "When first argument is a Response File, " <> |
| 73 | ++ "all arguments should be Response Files." |
| 74 | ++ exitFailure |
| 75 | ++ let |
| 76 | ++ responseFileNames :: NonEmpty FilePath |
| 77 | ++ responseFileNames = firstResponseFileName :| responseFileNames' |
| 78 | ++ |
| 79 | ++ forM_ responseFileNames $ \responseFileName -> do |
| 80 | ++ exists <- doesPathExist responseFileName |
| 81 | ++ when (not exists) $ do |
| 82 | ++ putStrLn $ "Response File '" <> responseFileName <> "' does not exist" |
| 83 | ++ exitFailure |
| 84 | ++ |
| 85 | ++ -- read all Response Files |
| 86 | ++ responseFileNamesAndText :: NonEmpty (FilePath, String) <- |
| 87 | ++ forM responseFileNames $ \responseFileName -> |
| 88 | ++ fmap (responseFileName, ) (readFile responseFileName) |
| 89 | ++ forM_ responseFileNamesAndText $ \(responseFileName, responseFileText) -> |
| 90 | ++ -- parse first word of Response File, which should be a command |
| 91 | ++ case uncons $ words responseFileText of |
| 92 | ++ Nothing -> do |
| 93 | ++ putStrLn $ "Response File '" <> responseFileName <> "' has no command" |
| 94 | ++ exitFailure |
| 95 | ++ Just (responseFileCommand, args1) -> case lookup responseFileCommand hooks' of |
| 96 | ++ -- check command for validity |
| 97 | ++ -- It is important than a Response File cannot specify another Response File; |
| 98 | ++ -- this is prevented |
| 99 | ++ Nothing -> do |
| 100 | ++ putStrLn $ "Response File '" <> responseFileName <> |
| 101 | ++ "' command '" <> responseFileCommand <> "' invalid" |
| 102 | ++ exitFailure |
| 103 | ++ Just plugin -> do |
| 104 | ++ putStrLn $ "Response File '" <> responseFileName <> "':" |
| 105 | ++ parse plugin args1 |
| 106 | ++ |
| 107 | + where |
| 108 | ++ getResponseFileName :: String -> Maybe FilePath |
| 109 | ++ getResponseFileName s = do |
| 110 | ++ (firstChar, filename) <- uncons s |
| 111 | ++ if firstChar == '@' |
| 112 | ++ then pure filename |
| 113 | ++ else Nothing |
| 114 | ++ |
| 115 | ++ -- first member of tuple is list of Response File names, |
| 116 | ++ -- second member of tuple is list of all other arguments |
| 117 | ++ partitionFileNames :: [String] -> ([FilePath], [String]) |
| 118 | ++ partitionFileNames xs = let |
| 119 | ++ hasFileName :: [(String, Maybe FilePath)] |
| 120 | ++ hasFileName = fmap (\x -> (x, getResponseFileName x)) xs |
| 121 | ++ (fileNames, nonFileNames) :: ([Maybe FilePath], [String]) = |
| 122 | ++ bimap (fmap snd) (fmap fst) $ partition (isJust . snd) hasFileName |
| 123 | ++ in (catMaybes fileNames, nonFileNames) |
| 124 | ++ |
| 125 | + parse plugin args = |
| 126 | + case getOpt Permute (options plugin []) args of |
| 127 | + (_,_,errs) | not (null errs) |
| 128 | +@@ -66,7 +143,7 @@ dispatch (txt:args0) = do |
| 129 | + exitFailure |
| 130 | + (o,ns,_) -> do |
| 131 | + let flags = final_flags plugin |
| 132 | +- $ foldr (.) id o |
| 133 | ++ . foldr (.) id o |
| 134 | + $ init_flags plugin |
| 135 | + implementation plugin flags ns |
| 136 | + |
| 137 | +@@ -112,7 +189,7 @@ help_main _ [] = do |
| 138 | + help_main _ (sub_txt:_) = do |
| 139 | + case lookup sub_txt hooks' of |
| 140 | + Nothing -> do |
| 141 | +- putStrLn $ "no such hpc command : " ++ sub_txt |
| 142 | ++ putStrLn $ "no such HPC command: " <> sub_txt |
| 143 | + exitFailure |
| 144 | + Just plugin' -> do |
| 145 | + command_usage plugin' |
![iohk-bors[bot]](https://avatars.githubusercontent.com/in/17473?v=4&size=40){kind=avatar}
0 commit comments