5 import System.Console.GetOpt
6 import Data.Maybe ( fromMaybe )
7 import qualified HpcSet as Set
13 { outputFile :: String
14 , includeMods :: Set.Set String
15 , excludeMods :: Set.Set String
25 , altHighlight :: Bool
27 , combineFun :: CombineFun
33 , includeMods = Set.empty
34 , excludeMods = Set.empty
44 , altHighlight = False
50 -- We do this after reading flags, because the defaults
51 -- depends on if specific flags we used.
53 default_final_flags flags = flags
54 { hpcDirs = if null (hpcDirs flags)
57 , hsDirs = if null (hsDirs flags)
62 noArg :: String -> String -> (Flags -> Flags) -> OptDescr (Flags -> Flags)
63 noArg flag detail fn = Option [] [flag] (NoArg $ fn) detail
65 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> OptDescr (Flags -> Flags)
66 anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail
68 infoArg :: String -> OptDescr (Flags -> Flags)
69 infoArg info = Option [] [] (NoArg $ id) info
71 excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
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 }
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 }
89 = noArg "highlight-covered" "highlight covered code, rather that code gaps"
90 $ \ f -> f { altHighlight = True }
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)
100 postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
101 $ \ f -> f { funTotals = True }
102 -------------------------------------------------------------------------------
104 command_usage plugin =
106 "Usage: hpc " ++ (name plugin) ++ " " ++
108 if null (options plugin)
110 else usageInfo "\n\nOptions:\n" (options plugin)
112 hpcError :: Plugin -> String -> IO a
113 hpcError plugin msg = do
114 putStrLn $ "Error: " ++ msg
118 -------------------------------------------------------------------------------
120 data Plugin = Plugin { name :: String
122 , options :: [OptDescr (Flags -> Flags)]
124 , implementation :: Flags -> [String] -> IO ()
125 , init_flags :: Flags
126 , final_flags :: Flags -> Flags
129 ------------------------------------------------------------------------------
131 -- filterModules takes a list of candidate modules,
133 -- * excludes the excluded modules
134 -- * includes the rest if there are no explicity included modules
135 -- * otherwise, accepts just the included modules.
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
148 -- pkg name always ends with '/', main
149 (pkg_name,mod_name) =
150 case span (/= ':') full_mod of
151 (p,':':m) -> (p ++ ":",m)
153 _ -> error "impossible case in allowModule"
155 filterTix :: Flags -> Tix -> Tix
156 filterTix flags (Tix tixs) =
157 Tix $ filter (allowModule flags . tixModuleName) tixs
159 ------------------------------------------------------------------------------
160 -- HpcCombine specifics
162 data CombineFun = ADD | DIFF | SUB | ZERO
163 deriving (Eq,Show, Read, Enum)
165 combineFuns = [ (show comb,comb)
166 | comb <- [ADD .. ZERO]