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