|
| 1 | +diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs |
| 2 | +index db6ae9c948..c52a6262b3 100644 |
| 3 | +--- a/utils/hpc/HpcCombine.hs |
| 4 | ++++ b/utils/hpc/HpcCombine.hs |
| 5 | +@@ -18,7 +18,9 @@ import qualified Data.Map as Map |
| 6 | + sum_options :: FlagOptSeq |
| 7 | + sum_options |
| 8 | + = excludeOpt |
| 9 | ++ . excludesFromOpt |
| 10 | + . includeOpt |
| 11 | ++ . includesFromOpt |
| 12 | + . outputOpt |
| 13 | + . unionModuleOpt |
| 14 | + . verbosityOpt |
| 15 | +diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs |
| 16 | +index 975dbf4f65..c542dadae8 100644 |
| 17 | +--- a/utils/hpc/HpcDraft.hs |
| 18 | ++++ b/utils/hpc/HpcDraft.hs |
| 19 | +@@ -15,9 +15,13 @@ import Data.Tree |
| 20 | + draft_options :: FlagOptSeq |
| 21 | + draft_options |
| 22 | + = excludeOpt |
| 23 | ++ . excludesFromOpt |
| 24 | + . includeOpt |
| 25 | ++ . includesFromOpt |
| 26 | + . srcDirOpt |
| 27 | ++ . srcDirsFromOpt |
| 28 | + . hpcDirOpt |
| 29 | ++ . hpcDirsFromOpt |
| 30 | + . resetHpcDirsOpt |
| 31 | + . outputOpt |
| 32 | + . verbosityOpt |
| 33 | +diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs |
| 34 | +index 2d78375003..f19ff5f108 100644 |
| 35 | +--- a/utils/hpc/HpcFlags.hs |
| 36 | ++++ b/utils/hpc/HpcFlags.hs |
| 37 | +@@ -13,9 +13,13 @@ import System.FilePath |
| 38 | + data Flags = Flags |
| 39 | + { outputFile :: String |
| 40 | + , includeMods :: Set.Set String |
| 41 | ++ , includeModsFrom :: Maybe String |
| 42 | + , excludeMods :: Set.Set String |
| 43 | ++ , excludeModsFrom :: Maybe String |
| 44 | + , hpcDirs :: [String] |
| 45 | ++ , hpcDirsFrom :: Maybe String |
| 46 | + , srcDirs :: [String] |
| 47 | ++ , srcDirsFrom :: Maybe String |
| 48 | + , destDir :: String |
| 49 | + |
| 50 | + , perModule :: Bool |
| 51 | +@@ -36,9 +40,13 @@ default_flags :: Flags |
| 52 | + default_flags = Flags |
| 53 | + { outputFile = "-" |
| 54 | + , includeMods = Set.empty |
| 55 | ++ , includeModsFrom = Nothing |
| 56 | + , excludeMods = Set.empty |
| 57 | ++ , excludeModsFrom = Nothing |
| 58 | + , hpcDirs = [".hpc"] |
| 59 | ++ , hpcDirsFrom = Nothing |
| 60 | + , srcDirs = [] |
| 61 | ++ , srcDirsFrom = Nothing |
| 62 | + , destDir = "." |
| 63 | + |
| 64 | + , perModule = False |
| 65 | +@@ -76,32 +84,69 @@ default_final_flags flags = flags |
| 66 | + else srcDirs flags |
| 67 | + } |
| 68 | + |
| 69 | +-type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)] |
| 70 | ++type FlagOptSeq = [OptDescr (Flags -> IO Flags)] -> [OptDescr (Flags -> IO Flags)] |
| 71 | + |
| 72 | + noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq |
| 73 | +-noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail |
| 74 | ++noArg flag detail fn = noArgIO flag detail (pure . fn) |
| 75 | ++ |
| 76 | ++noArgIO :: String -> String -> (Flags -> IO Flags) -> FlagOptSeq |
| 77 | ++noArgIO flag detail fn = (:) $ Option [] [flag] (NoArg fn) detail |
| 78 | + |
| 79 | + anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq |
| 80 | +-anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail |
| 81 | ++anArg flag detail argtype fn = anArgIO flag detail argtype (\s xs -> pure $ fn s xs) |
| 82 | ++ |
| 83 | ++anArgIO :: String -> String -> String -> (String -> Flags -> IO Flags) -> FlagOptSeq |
| 84 | ++anArgIO flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail |
| 85 | ++ |
| 86 | ++optArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq |
| 87 | ++optArg flag detail argtype fn = optArgIO flag detail argtype (\s xs -> pure $ fn s xs) |
| 88 | ++ |
| 89 | ++optArgIO :: String -> String -> String -> (String -> Flags -> IO Flags) -> FlagOptSeq |
| 90 | ++optArgIO flag detail argtype fn = (:) $ Option [] [flag] (OptArg (maybe pure fn) argtype) detail |
| 91 | + |
| 92 | + infoArg :: String -> FlagOptSeq |
| 93 | +-infoArg info = (:) $ Option [] [] (NoArg $ id) info |
| 94 | ++infoArg info = (:) $ Option [] [] (NoArg $ pure) info |
| 95 | + |
| 96 | +-excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt, |
| 97 | +- destDirOpt, outputOpt, verbosityOpt, |
| 98 | ++excludeOpt, excludesFromOpt, includeOpt, includesFromOpt, hpcDirOpt, hpcDirsFromOpt, resetHpcDirsOpt, |
| 99 | ++ srcDirOpt, srcDirsFromOpt, destDirOpt, outputOpt, verbosityOpt, |
| 100 | + perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt, |
| 101 | + altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt, |
| 102 | + mapFunOptInfo, unionModuleOpt :: FlagOptSeq |
| 103 | + excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" |
| 104 | + $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f } |
| 105 | ++excludesFromOpt = optArgIO "excludes-from" "a file with a list of MODULE and/or PACKAGE names to exclude" "FILE" |
| 106 | ++ (\ a f -> do |
| 107 | ++ content <- readFile a |
| 108 | ++ pure $ f |
| 109 | ++ { excludeMods = excludeMods f `Set.union` Set.fromList (lines content) |
| 110 | ++ , excludeModsFrom = Just a |
| 111 | ++ } |
| 112 | ++ ) |
| 113 | + |
| 114 | + includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" |
| 115 | + $ \ a f -> f { includeMods = a `Set.insert` includeMods f } |
| 116 | + |
| 117 | ++includesFromOpt = optArgIO "includes-from" "a file with a list of MODULE and/or PACKAGE names to include" "FILE" |
| 118 | ++ (\ a f -> do |
| 119 | ++ content <- readFile a |
| 120 | ++ pure $ f |
| 121 | ++ { includeMods = includeMods f `Set.union` Set.fromList (lines content) |
| 122 | ++ , includeModsFrom = Just a |
| 123 | ++ } |
| 124 | ++ ) |
| 125 | + hpcDirOpt = anArg "hpcdir" "append sub-directory that contains .mix files" "DIR" |
| 126 | + (\ a f -> f { hpcDirs = hpcDirs f ++ [a] }) |
| 127 | + . infoArg "default .hpc [rarely used]" |
| 128 | + |
| 129 | ++hpcDirsFromOpt = optArgIO "hpcdirs-from" "read from a file and append sub-directories that contain .mix files" "FILE" |
| 130 | ++ (\ a f -> do |
| 131 | ++ content <- readFile a |
| 132 | ++ pure $ f |
| 133 | ++ { hpcDirs = hpcDirs f ++ lines content |
| 134 | ++ , hpcDirsFrom = Just a |
| 135 | ++ } |
| 136 | ++ ) |
| 137 | ++ |
| 138 | + resetHpcDirsOpt = noArg "reset-hpcdirs" "empty the list of hpcdir's" |
| 139 | + (\ f -> f { hpcDirs = [] }) |
| 140 | + . infoArg "[rarely used]" |
| 141 | +@@ -110,6 +155,16 @@ srcDirOpt = anArg "srcdir" "path to source directory of .hs files" "DI |
| 142 | + (\ a f -> f { srcDirs = srcDirs f ++ [a] }) |
| 143 | + . infoArg "multi-use of srcdir possible" |
| 144 | + |
| 145 | ++ |
| 146 | ++srcDirsFromOpt = optArgIO "srcdirs-from" "read paths to source directories of .hs files from a file" "FILE" |
| 147 | ++ (\ a f -> do |
| 148 | ++ content <- readFile a |
| 149 | ++ pure $ f |
| 150 | ++ { srcDirs = srcDirs f ++ lines content |
| 151 | ++ , srcDirsFrom = Just a |
| 152 | ++ } |
| 153 | ++ ) |
| 154 | ++ |
| 155 | + destDirOpt = anArg "destdir" "path to write output to" "DIR" |
| 156 | + $ \ a f -> f { destDir = a } |
| 157 | + |
| 158 | +diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs |
| 159 | +index 1d5efcf6d6..7ed952aeaa 100644 |
| 160 | +--- a/utils/hpc/HpcMarkup.hs |
| 161 | ++++ b/utils/hpc/HpcMarkup.hs |
| 162 | +@@ -25,9 +25,13 @@ import qualified Data.Set as Set |
| 163 | + markup_options :: FlagOptSeq |
| 164 | + markup_options |
| 165 | + = excludeOpt |
| 166 | ++ . excludesFromOpt |
| 167 | + . includeOpt |
| 168 | ++ . includesFromOpt |
| 169 | + . srcDirOpt |
| 170 | ++ . srcDirsFromOpt |
| 171 | + . hpcDirOpt |
| 172 | ++ . hpcDirsFromOpt |
| 173 | + . resetHpcDirsOpt |
| 174 | + . funTotalsOpt |
| 175 | + . altHighlightOpt |
| 176 | +diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs |
| 177 | +index c4f8e96bf4..0248fc2a8a 100644 |
| 178 | +--- a/utils/hpc/HpcOverlay.hs |
| 179 | ++++ b/utils/hpc/HpcOverlay.hs |
| 180 | +@@ -12,7 +12,9 @@ import Data.Tree |
| 181 | + overlay_options :: FlagOptSeq |
| 182 | + overlay_options |
| 183 | + = srcDirOpt |
| 184 | ++ . srcDirsFromOpt |
| 185 | + . hpcDirOpt |
| 186 | ++ . hpcDirsFromOpt |
| 187 | + . resetHpcDirsOpt |
| 188 | + . outputOpt |
| 189 | + . verbosityOpt |
| 190 | +diff --git a/utils/hpc/HpcReport.hs b/utils/hpc/HpcReport.hs |
| 191 | +index 4c975be425..c81ea6a966 100644 |
| 192 | +--- a/utils/hpc/HpcReport.hs |
| 193 | ++++ b/utils/hpc/HpcReport.hs |
| 194 | +@@ -269,9 +269,13 @@ report_options |
| 195 | + = perModuleOpt |
| 196 | + . decListOpt |
| 197 | + . excludeOpt |
| 198 | ++ . excludesFromOpt |
| 199 | + . includeOpt |
| 200 | ++ . includesFromOpt |
| 201 | + . srcDirOpt |
| 202 | ++ . srcDirsFromOpt |
| 203 | + . hpcDirOpt |
| 204 | ++ . hpcDirsFromOpt |
| 205 | + . resetHpcDirsOpt |
| 206 | + . xmlOutputOpt |
| 207 | + . verbosityOpt |
| 208 | +diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs |
| 209 | +index f0c628e422..f80db19114 100644 |
| 210 | +--- a/utils/hpc/HpcShowTix.hs |
| 211 | ++++ b/utils/hpc/HpcShowTix.hs |
| 212 | +@@ -10,9 +10,13 @@ import qualified Data.Set as Set |
| 213 | + showtix_options :: FlagOptSeq |
| 214 | + showtix_options |
| 215 | + = excludeOpt |
| 216 | ++ . excludesFromOpt |
| 217 | + . includeOpt |
| 218 | ++ . includesFromOpt |
| 219 | + . srcDirOpt |
| 220 | ++ . srcDirsFromOpt |
| 221 | + . hpcDirOpt |
| 222 | ++ . hpcDirsFromOpt |
| 223 | + . resetHpcDirsOpt |
| 224 | + . outputOpt |
| 225 | + . verbosityOpt |
| 226 | +diff --git a/utils/hpc/Main.hs b/utils/hpc/Main.hs |
| 227 | +index 3f1813f243..64f88341eb 100644 |
| 228 | +--- a/utils/hpc/Main.hs |
| 229 | ++++ b/utils/hpc/Main.hs |
| 230 | +@@ -1,6 +1,7 @@ |
| 231 | + -- (c) 2007 Andy Gill |
| 232 | + |
| 233 | + -- Main driver for Hpc |
| 234 | ++import Control.Monad |
| 235 | + import Data.Version |
| 236 | + import System.Environment |
| 237 | + import System.Exit |
| 238 | +@@ -65,9 +66,8 @@ dispatch (txt:args0) = do |
| 239 | + command_usage plugin |
| 240 | + exitFailure |
| 241 | + (o,ns,_) -> do |
| 242 | +- let flags = final_flags plugin |
| 243 | +- $ foldr (.) id o |
| 244 | +- $ init_flags plugin |
| 245 | ++ intermediate_flags <- foldr (<=<) pure o $ init_flags plugin |
| 246 | ++ let flags = final_flags plugin intermediate_flags |
| 247 | + implementation plugin flags ns |
| 248 | + |
| 249 | + main :: IO () |
0 commit comments