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