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 -> Either String TixModule -> IO Mix
114 readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags
115 | dir <- srcDirs flags
118 -------------------------------------------------------------------------------
120 command_usage plugin =
122 "Usage: hpc " ++ (name plugin) ++ " " ++
124 if null (options plugin [])
126 else usageInfo "\n\nOptions:\n" (options plugin [])
128 hpcError :: Plugin -> String -> IO a
129 hpcError plugin msg = do
130 putStrLn $ "Error: " ++ msg
134 -------------------------------------------------------------------------------
136 data Plugin = Plugin { name :: String
138 , options :: FlagOptSeq
140 , implementation :: Flags -> [String] -> IO ()
141 , init_flags :: Flags
142 , final_flags :: Flags -> Flags
145 ------------------------------------------------------------------------------
147 -- filterModules takes a list of candidate modules,
149 -- * excludes the excluded modules
150 -- * includes the rest if there are no explicity included modules
151 -- * otherwise, accepts just the included modules.
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
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)
170 _ -> error "impossible case in allowModule"
172 filterTix :: Flags -> Tix -> Tix
173 filterTix flags (Tix tixs) =
174 Tix $ filter (allowModule flags . tixModuleName) tixs
178 ------------------------------------------------------------------------------
179 -- HpcCombine specifics
181 data CombineFun = ADD | DIFF | SUB | ZERO
182 deriving (Eq,Show, Read, Enum)
184 combineFuns = [ (show comb,comb)
185 | comb <- [ADD .. ZERO]