5 import System.Console.GetOpt
6 import qualified HpcSet as Set
12 { outputFile :: String
13 , includeMods :: Set.Set String
14 , excludeMods :: Set.Set String
24 , altHighlight :: Bool
26 , combineFun :: CombineFun
32 , includeMods = Set.empty
33 , excludeMods = Set.empty
43 , altHighlight = False
49 -- We do this after reading flags, because the defaults
50 -- depends on if specific flags we used.
52 default_final_flags flags = flags
53 { hpcDirs = if null (hpcDirs flags)
56 , hsDirs = if null (hsDirs flags)
61 noArg :: String -> String -> (Flags -> Flags) -> OptDescr (Flags -> Flags)
62 noArg flag detail fn = Option [] [flag] (NoArg $ fn) detail
64 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> OptDescr (Flags -> Flags)
65 anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail
67 infoArg :: String -> OptDescr (Flags -> Flags)
68 infoArg info = Option [] [] (NoArg $ id) info
70 excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
72 includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
73 hpcDirOpt = anArg "hpcdir" "path to .mix files (default .hpc)" "DIR"
74 $ \ a f -> f { hpcDirs = hpcDirs f ++ [a] }
75 hsDirOpt = anArg "hsdir" "path to .hs files (default .)" "DIR"
76 $ \ a f -> f { hsDirs = hsDirs f ++ [a] }
77 destDirOpt = anArg "destdir" "path to write output to" "DIR"
78 $ \ a f -> f { destDir = a }
79 outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
82 perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
83 decListOpt = noArg "dec-list" "show unused decls" $ \ f -> f { decList = True }
84 xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True }
85 funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts"
86 $ \ f -> f { funTotals = True }
88 = noArg "highlight-covered" "highlight covered code, rather that code gaps"
89 $ \ f -> f { altHighlight = True }
91 combineFunOpt = anArg "combine"
92 "combine .tix files with join function, default = ADD" "FUNCTION"
93 $ \ a f -> case reads (map toUpper a) of
94 [(c,"")] -> f { combineFun = c }
95 _ -> error $ "no such combine function : " ++ a
96 combineFunOptInfo = infoArg
97 $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst combineFuns)
99 postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
100 $ \ f -> f { funTotals = True }
101 -------------------------------------------------------------------------------
103 command_usage plugin =
105 "Usage: hpc " ++ (name plugin) ++ " " ++
107 if null (options plugin)
109 else usageInfo "\n\nOptions:\n" (options plugin)
111 hpcError :: Plugin -> String -> IO a
112 hpcError plugin msg = do
113 putStrLn $ "Error: " ++ msg
117 -------------------------------------------------------------------------------
119 data Plugin = Plugin { name :: String
121 , options :: [OptDescr (Flags -> Flags)]
123 , implementation :: Flags -> [String] -> IO ()
124 , init_flags :: Flags
125 , final_flags :: Flags -> Flags
128 ------------------------------------------------------------------------------
130 -- filterModules takes a list of candidate modules,
132 -- * excludes the excluded modules
133 -- * includes the rest if there are no explicity included modules
134 -- * otherwise, accepts just the included modules.
136 allowModule :: Flags -> String -> Bool
137 allowModule flags full_mod
138 | full_mod `Set.member` excludeMods flags = False
139 | pkg_name `Set.member` excludeMods flags = False
140 | mod_name `Set.member` excludeMods flags = False
141 | Set.null (includeMods flags) = True
142 | full_mod `Set.member` includeMods flags = True
143 | pkg_name `Set.member` includeMods flags = True
144 | mod_name `Set.member` includeMods flags = True
147 -- pkg name always ends with '/', main
148 (pkg_name,mod_name) =
149 case span (/= '/') full_mod of
150 (p,'/':m) -> (p ++ ":",m)
152 _ -> error "impossible case in allowModule"
154 filterTix :: Flags -> Tix -> Tix
155 filterTix flags (Tix tixs) =
156 Tix $ filter (allowModule flags . tixModuleName) tixs
160 ------------------------------------------------------------------------------
161 -- HpcCombine specifics
163 data CombineFun = ADD | DIFF | SUB | ZERO
164 deriving (Eq,Show, Read, Enum)
166 combineFuns = [ (show comb,comb)
167 | comb <- [ADD .. ZERO]