Adding draft and show to hpc
[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 System.Exit
11
12 data Flags = Flags
13 { outputFile :: String
14 , includeMods :: Set.Set String
15 , excludeMods :: Set.Set String
16 , hsDirs :: [String]
17 , hpcDirs :: [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
28 , postInvert :: Bool
29 }
30
31 default_flags = Flags
32 { outputFile = "-"
33 , includeMods = Set.empty
34 , excludeMods = Set.empty
35 , hpcDirs = []
36 , hsDirs = []
37 , destDir = "."
38
39 , perModule = False
40 , decList = False
41 , xmlOutput = False
42
43 , funTotals = False
44 , altHighlight = False
45
46 , combineFun = ADD
47 , postInvert = False
48 }
49
50 -- We do this after reading flags, because the defaults
51 -- depends on if specific flags we used.
52
53 default_final_flags flags = flags
54 { hpcDirs = if null (hpcDirs flags)
55 then [".hpc"]
56 else hpcDirs flags
57 , hsDirs = if null (hsDirs flags)
58 then ["."]
59 else hsDirs flags
60 }
61
62 noArg :: String -> String -> (Flags -> Flags) -> OptDescr (Flags -> Flags)
63 noArg flag detail fn = Option [] [flag] (NoArg $ fn) detail
64
65 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> OptDescr (Flags -> Flags)
66 anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail
67
68 infoArg :: String -> OptDescr (Flags -> Flags)
69 infoArg info = Option [] [] (NoArg $ id) info
70
71 excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
72
73 includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
74 hpcDirOpt = anArg "hpcdir" "path to .mix files (default .hpc)" "DIR"
75 $ \ a f -> f { hpcDirs = hpcDirs f ++ [a] }
76 hsDirOpt = anArg "hsdir" "path to .hs files (default .)" "DIR"
77 $ \ a f -> f { hsDirs = hsDirs f ++ [a] }
78 destDirOpt = anArg "destdir" "path to write output to" "DIR"
79 $ \ a f -> f { destDir = a }
80 outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
81 -- markup
82
83 perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
84 decListOpt = noArg "dec-list" "show unused decls" $ \ f -> f { decList = True }
85 xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True }
86 funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts"
87 $ \ f -> f { funTotals = True }
88 altHighlightOpt
89 = noArg "highlight-covered" "highlight covered code, rather that code gaps"
90 $ \ f -> f { altHighlight = True }
91
92 combineFunOpt = anArg "combine"
93 "combine .tix files with join function, default = ADD" "FUNCTION"
94 $ \ a f -> case reads (map toUpper a) of
95 [(c,"")] -> f { combineFun = c }
96 _ -> error $ "no such combine function : " ++ a
97 combineFunOptInfo = infoArg
98 $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst combineFuns)
99
100 postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
101 $ \ f -> f { funTotals = True }
102 -------------------------------------------------------------------------------
103
104 command_usage plugin =
105 putStrLn $
106 "Usage: hpc " ++ (name plugin) ++ " " ++
107 (usage plugin) ++
108 if null (options plugin)
109 then ""
110 else usageInfo "\n\nOptions:\n" (options plugin)
111
112 hpcError :: Plugin -> String -> IO a
113 hpcError plugin msg = do
114 putStrLn $ "Error: " ++ msg
115 command_usage plugin
116 exitFailure
117
118 -------------------------------------------------------------------------------
119
120 data Plugin = Plugin { name :: String
121 , usage :: String
122 , options :: [OptDescr (Flags -> Flags)]
123 , summary :: String
124 , implementation :: Flags -> [String] -> IO ()
125 , init_flags :: Flags
126 , final_flags :: Flags -> Flags
127 }
128
129 ------------------------------------------------------------------------------
130
131 -- filterModules takes a list of candidate modules,
132 -- and
133 -- * excludes the excluded modules
134 -- * includes the rest if there are no explicity included modules
135 -- * otherwise, accepts just the included modules.
136
137 allowModule :: Flags -> String -> Bool
138 allowModule flags full_mod
139 | full_mod `Set.member` excludeMods flags = False
140 | pkg_name `Set.member` excludeMods flags = False
141 | mod_name `Set.member` excludeMods flags = False
142 | Set.null (includeMods flags) = True
143 | full_mod `Set.member` includeMods flags = True
144 | pkg_name `Set.member` includeMods flags = True
145 | mod_name `Set.member` includeMods flags = True
146 | otherwise = False
147 where
148 -- pkg name always ends with '/', main
149 (pkg_name,mod_name) =
150 case span (/= '/') full_mod of
151 (p,'/':m) -> (p ++ ":",m)
152 (m,[]) -> (":",m)
153 _ -> error "impossible case in allowModule"
154
155 filterTix :: Flags -> Tix -> Tix
156 filterTix flags (Tix tixs) =
157 Tix $ filter (allowModule flags . tixModuleName) tixs
158
159
160
161 ------------------------------------------------------------------------------
162 -- HpcCombine specifics
163
164 data CombineFun = ADD | DIFF | SUB | ZERO
165 deriving (Eq,Show, Read, Enum)
166
167 combineFuns = [ (show comb,comb)
168 | comb <- [ADD .. ZERO]
169 ]