5 import System.Console.GetOpt
6 import Data.Maybe ( fromMaybe )
7 import qualified HpcSet as Set
14 { outputFile :: String
15 , includeMods :: Set.Set String
16 , excludeMods :: Set.Set String
26 , altHighlight :: Bool
28 , combineFun :: CombineFun
34 , includeMods = Set.empty
35 , excludeMods = Set.empty
45 , altHighlight = False
51 -- We do this after reading flags, because the defaults
52 -- depends on if specific flags we used.
54 default_final_flags flags = flags
55 { srcDirs = if null (srcDirs flags)
60 type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
62 noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
63 noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
65 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
66 anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
68 infoArg :: String -> FlagOptSeq
69 infoArg info = (:) $ Option [] [] (NoArg $ id) info
71 excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
72 $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
74 includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
75 $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
77 hpcDirOpt = anArg "hpcdir" "sub-directory that contains .mix files" "DIR"
78 (\ a f -> f { hpcDir = a })
79 . infoArg "default .hpc [rarely used]"
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"
85 destDirOpt = anArg "destdir" "path to write output to" "DIR"
86 $ \ a f -> f { destDir = a }
89 outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
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 }
98 = noArg "highlight-covered" "highlight covered code, rather that code gaps"
99 $ \ f -> f { altHighlight = True }
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)
109 postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
110 $ \ f -> f { funTotals = True }
111 -------------------------------------------------------------------------------
113 readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags
114 | dir <- srcDirs flags
117 -------------------------------------------------------------------------------
119 command_usage plugin =
121 "Usage: hpc " ++ (name plugin) ++ " " ++
123 if null (options plugin [])
125 else usageInfo "\n\nOptions:\n" (options plugin [])
127 hpcError :: Plugin -> String -> IO a
128 hpcError plugin msg = do
129 putStrLn $ "Error: " ++ msg
133 -------------------------------------------------------------------------------
135 data Plugin = Plugin { name :: String
137 , options :: FlagOptSeq
139 , implementation :: Flags -> [String] -> IO ()
140 , init_flags :: Flags
141 , final_flags :: Flags -> Flags
144 ------------------------------------------------------------------------------
146 -- filterModules takes a list of candidate modules,
148 -- * excludes the excluded modules
149 -- * includes the rest if there are no explicity included modules
150 -- * otherwise, accepts just the included modules.
152 allowModule :: Flags -> String -> Bool
153 allowModule flags full_mod
154 | full_mod' `Set.member` excludeMods flags = False
155 | pkg_name `Set.member` excludeMods flags = False
156 | mod_name `Set.member` excludeMods flags = False
157 | Set.null (includeMods flags) = True
158 | full_mod' `Set.member` includeMods flags = True
159 | pkg_name `Set.member` includeMods flags = True
160 | mod_name `Set.member` includeMods flags = True
163 full_mod' = pkg_name ++ mod_name
164 -- pkg name always ends with '/', main
165 (pkg_name,mod_name) =
166 case span (/= '/') full_mod of
167 (p,'/':m) -> (p ++ ":",m)
169 _ -> error "impossible case in allowModule"
171 filterTix :: Flags -> Tix -> Tix
172 filterTix flags (Tix tixs) =
173 Tix $ filter (allowModule flags . tixModuleName) tixs
177 ------------------------------------------------------------------------------
178 -- HpcCombine specifics
180 data CombineFun = ADD | DIFF | SUB | ZERO
181 deriving (Eq,Show, Read, Enum)
183 combineFuns = [ (show comb,comb)
184 | comb <- [ADD .. ZERO]