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