017030986ae00c142a3c2f2153bb4e341c5b1a17
[ghc.git] / utils / hpc / HpcFlags.hs
1 -- (c) 2007 Andy Gill
2
3 module HpcFlags where
4
5 import System.Console.GetOpt
6 import qualified Data.Set as Set
7 import Data.Char
8 import Trace.Hpc.Tix
9 import Trace.Hpc.Mix
10 import System.Exit
11
12 data Flags = Flags
13 { outputFile :: String
14 , includeMods :: Set.Set String
15 , excludeMods :: Set.Set String
16 , hpcDirs :: [String]
17 , srcDirs :: [String]
18 , destDir :: String
19
20 , perModule :: Bool
21 , decList :: Bool
22 , xmlOutput :: Bool
23
24 , funTotals :: Bool
25 , altHighlight :: Bool
26
27 , combineFun :: CombineFun -- tick-wise combine
28 , postFun :: PostFun --
29 , mergeModule :: MergeFun -- module-wise merge
30
31 , verbosity :: Verbosity
32 }
33
34 default_flags :: Flags
35 default_flags = Flags
36 { outputFile = "-"
37 , includeMods = Set.empty
38 , excludeMods = Set.empty
39 , hpcDirs = [".hpc"]
40 , srcDirs = []
41 , destDir = "."
42
43 , perModule = False
44 , decList = False
45 , xmlOutput = False
46
47 , funTotals = False
48 , altHighlight = False
49
50 , combineFun = ADD
51 , postFun = ID
52 , mergeModule = INTERSECTION
53
54 , verbosity = Normal
55 }
56
57
58 data Verbosity = Silent | Normal | Verbose
59 deriving (Eq, Ord)
60
61 verbosityFromString :: String -> Verbosity
62 verbosityFromString "0" = Silent
63 verbosityFromString "1" = Normal
64 verbosityFromString "2" = Verbose
65 verbosityFromString v = error $ "unknown verbosity: " ++ v
66
67
68 -- We do this after reading flags, because the defaults
69 -- depends on if specific flags we used.
70
71 default_final_flags :: Flags -> Flags
72 default_final_flags flags = flags
73 { srcDirs = if null (srcDirs flags)
74 then ["."]
75 else srcDirs flags
76 }
77
78 type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
79
80 noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
81 noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
82
83 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
84 anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
85
86 infoArg :: String -> FlagOptSeq
87 infoArg info = (:) $ Option [] [] (NoArg $ id) info
88
89 excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt,
90 destDirOpt, outputOpt, verbosityOpt,
91 perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
92 altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
93 mapFunOptInfo, unionModuleOpt :: FlagOptSeq
94 excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
95 $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
96
97 includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
98 $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
99
100 hpcDirOpt = anArg "hpcdir" "append sub-directory that contains .mix files" "DIR"
101 (\ a f -> f { hpcDirs = hpcDirs f ++ [a] })
102 . infoArg "default .hpc [rarely used]"
103
104 resetHpcDirsOpt = noArg "reset-hpcdirs" "empty the list of hpcdir's"
105 (\ f -> f { hpcDirs = [] })
106 . infoArg "[rarely used]"
107
108 srcDirOpt = anArg "srcdir" "path to source directory of .hs files" "DIR"
109 (\ a f -> f { srcDirs = srcDirs f ++ [a] })
110 . infoArg "multi-use of srcdir possible"
111
112 destDirOpt = anArg "destdir" "path to write output to" "DIR"
113 $ \ a f -> f { destDir = a }
114
115
116 outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
117
118 verbosityOpt = anArg "verbosity" "verbosity level, 0-2" "[0-2]"
119 (\ a f -> f { verbosity = verbosityFromString a })
120 . infoArg "default 1"
121
122 -- markup
123
124 perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
125 decListOpt = noArg "decl-list" "show unused decls" $ \ f -> f { decList = True }
126 xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True }
127 funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts"
128 $ \ f -> f { funTotals = True }
129 altHighlightOpt
130 = noArg "highlight-covered" "highlight covered code, rather that code gaps"
131 $ \ f -> f { altHighlight = True }
132
133 combineFunOpt = anArg "function"
134 "combine .tix files with join function, default = ADD" "FUNCTION"
135 $ \ a f -> case reads (map toUpper a) of
136 [(c,"")] -> f { combineFun = c }
137 _ -> error $ "no such combine function : " ++ a
138 combineFunOptInfo = infoArg
139 $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)
140
141 mapFunOpt = anArg "function"
142 "apply function to .tix files, default = ID" "FUNCTION"
143 $ \ a f -> case reads (map toUpper a) of
144 [(c,"")] -> f { postFun = c }
145 _ -> error $ "no such combine function : " ++ a
146 mapFunOptInfo = infoArg
147 $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)
148
149 unionModuleOpt = noArg "union"
150 "use the union of the module namespace (default is intersection)"
151 $ \ f -> f { mergeModule = UNION }
152
153
154 -------------------------------------------------------------------------------
155
156 readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
157 readMixWithFlags flags modu = readMix [ dir ++ "/" ++ hpcDir
158 | dir <- srcDirs flags
159 , hpcDir <- hpcDirs flags
160 ] modu
161
162 -------------------------------------------------------------------------------
163
164 command_usage :: Plugin -> IO ()
165 command_usage plugin =
166 putStrLn $
167 "Usage: hpc " ++ (name plugin) ++ " " ++
168 (usage plugin) ++
169 "\n" ++ summary plugin ++ "\n" ++
170 if null (options plugin [])
171 then ""
172 else usageInfo "\n\nOptions:\n" (options plugin [])
173
174 hpcError :: Plugin -> String -> IO a
175 hpcError plugin msg = do
176 putStrLn $ "Error: " ++ msg
177 command_usage plugin
178 exitFailure
179
180 -------------------------------------------------------------------------------
181
182 data Plugin = Plugin { name :: String
183 , usage :: String
184 , options :: FlagOptSeq
185 , summary :: String
186 , implementation :: Flags -> [String] -> IO ()
187 , init_flags :: Flags
188 , final_flags :: Flags -> Flags
189 }
190
191 ------------------------------------------------------------------------------
192
193 -- filterModules takes a list of candidate modules,
194 -- and
195 -- * excludes the excluded modules
196 -- * includes the rest if there are no explicity included modules
197 -- * otherwise, accepts just the included modules.
198
199 allowModule :: Flags -> String -> Bool
200 allowModule flags full_mod
201 | full_mod' `Set.member` excludeMods flags = False
202 | pkg_name `Set.member` excludeMods flags = False
203 | mod_name `Set.member` excludeMods flags = False
204 | Set.null (includeMods flags) = True
205 | full_mod' `Set.member` includeMods flags = True
206 | pkg_name `Set.member` includeMods flags = True
207 | mod_name `Set.member` includeMods flags = True
208 | otherwise = False
209 where
210 full_mod' = pkg_name ++ mod_name
211 -- pkg name always ends with '/', main
212 (pkg_name,mod_name) =
213 case span (/= '/') full_mod of
214 (p,'/':m) -> (p ++ ":",m)
215 (m,[]) -> (":",m)
216 _ -> error "impossible case in allowModule"
217
218 filterTix :: Flags -> Tix -> Tix
219 filterTix flags (Tix tixs) =
220 Tix $ filter (allowModule flags . tixModuleName) tixs
221
222
223
224 ------------------------------------------------------------------------------
225 -- HpcCombine specifics
226
227 data CombineFun = ADD | DIFF | SUB
228 deriving (Eq,Show, Read, Enum)
229
230 theCombineFun :: CombineFun -> Integer -> Integer -> Integer
231 theCombineFun fn = case fn of
232 ADD -> \ l r -> l + r
233 SUB -> \ l r -> max 0 (l - r)
234 DIFF -> \ g b -> if g > 0 then 0 else min 1 b
235
236 foldFuns :: [ (String,CombineFun) ]
237 foldFuns = [ (show comb,comb)
238 | comb <- [ADD .. SUB]
239 ]
240
241 data PostFun = ID | INV | ZERO
242 deriving (Eq,Show, Read, Enum)
243
244 thePostFun :: PostFun -> Integer -> Integer
245 thePostFun ID x = x
246 thePostFun INV 0 = 1
247 thePostFun INV _ = 0
248 thePostFun ZERO _ = 0
249
250 postFuns :: [(String, PostFun)]
251 postFuns = [ (show pos,pos)
252 | pos <- [ID .. ZERO]
253 ]
254
255
256 data MergeFun = INTERSECTION | UNION
257 deriving (Eq,Show, Read, Enum)
258
259 theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a
260 theMergeFun INTERSECTION = Set.intersection
261 theMergeFun UNION = Set.union
262
263 mergeFuns :: [(String, MergeFun)]
264 mergeFuns = [ (show pos,pos)
265 | pos <- [INTERSECTION,UNION]
266 ]
267