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