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