5 import System.Console.GetOpt
6 import qualified HpcSet as Set
13 { outputFile :: String
14 , includeMods :: Set.Set String
15 , excludeMods :: Set.Set String
25 , altHighlight :: Bool
27 , combineFun :: CombineFun -- tick-wise combine
28 , postFun :: PostFun --
29 , mergeModule :: MergeFun -- module-wise merge
32 default_flags :: Flags
35 , includeMods = Set.empty
36 , excludeMods = Set.empty
46 , altHighlight = False
50 , mergeModule = INTERSECTION
54 -- We do this after reading flags, because the defaults
55 -- depends on if specific flags we used.
57 default_final_flags :: Flags -> Flags
58 default_final_flags flags = flags
59 { srcDirs = if null (srcDirs flags)
64 type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
66 noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
67 noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
69 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
70 anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
72 infoArg :: String -> FlagOptSeq
73 infoArg info = (:) $ Option [] [] (NoArg $ id) info
75 excludeOpt, includeOpt, hpcDirOpt, srcDirOpt, destDirOpt, outputOpt,
76 perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
77 altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
78 mapFunOptInfo, unionModuleOpt :: FlagOptSeq
79 excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
80 $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
82 includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
83 $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
85 hpcDirOpt = anArg "hpcdir" "sub-directory that contains .mix files" "DIR"
86 (\ a f -> f { hpcDir = a })
87 . infoArg "default .hpc [rarely used]"
89 srcDirOpt = anArg "srcdir" "path to source directory of .hs files" "DIR"
90 (\ a f -> f { srcDirs = srcDirs f ++ [a] })
91 . infoArg "multi-use of srcdir possible"
93 destDirOpt = anArg "destdir" "path to write output to" "DIR"
94 $ \ a f -> f { destDir = a }
97 outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
100 perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
101 decListOpt = noArg "decl-list" "show unused decls" $ \ f -> f { decList = True }
102 xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True }
103 funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts"
104 $ \ f -> f { funTotals = True }
106 = noArg "highlight-covered" "highlight covered code, rather that code gaps"
107 $ \ f -> f { altHighlight = True }
109 combineFunOpt = anArg "function"
110 "combine .tix files with join function, default = ADD" "FUNCTION"
111 $ \ a f -> case reads (map toUpper a) of
112 [(c,"")] -> f { combineFun = c }
113 _ -> error $ "no such combine function : " ++ a
114 combineFunOptInfo = infoArg
115 $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)
117 mapFunOpt = anArg "function"
118 "apply function to .tix files, default = ID" "FUNCTION"
119 $ \ a f -> case reads (map toUpper a) of
120 [(c,"")] -> f { postFun = c }
121 _ -> error $ "no such combine function : " ++ a
122 mapFunOptInfo = infoArg
123 $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)
125 unionModuleOpt = noArg "union"
126 "use the union of the module namespace (default is intersection)"
127 $ \ f -> f { mergeModule = UNION }
130 -------------------------------------------------------------------------------
132 readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
133 readMixWithFlags flags modu = readMix [ dir ++ "/" ++ hpcDir flags
134 | dir <- srcDirs flags
137 -------------------------------------------------------------------------------
139 command_usage :: Plugin -> IO ()
140 command_usage plugin =
142 "Usage: hpc " ++ (name plugin) ++ " " ++
144 "\n" ++ summary plugin ++ "\n" ++
145 if null (options plugin [])
147 else usageInfo "\n\nOptions:\n" (options plugin [])
149 hpcError :: Plugin -> String -> IO a
150 hpcError plugin msg = do
151 putStrLn $ "Error: " ++ msg
155 -------------------------------------------------------------------------------
157 data Plugin = Plugin { name :: String
159 , options :: FlagOptSeq
161 , implementation :: Flags -> [String] -> IO ()
162 , init_flags :: Flags
163 , final_flags :: Flags -> Flags
166 ------------------------------------------------------------------------------
168 -- filterModules takes a list of candidate modules,
170 -- * excludes the excluded modules
171 -- * includes the rest if there are no explicity included modules
172 -- * otherwise, accepts just the included modules.
174 allowModule :: Flags -> String -> Bool
175 allowModule flags full_mod
176 | full_mod' `Set.member` excludeMods flags = False
177 | pkg_name `Set.member` excludeMods flags = False
178 | mod_name `Set.member` excludeMods flags = False
179 | Set.null (includeMods flags) = True
180 | full_mod' `Set.member` includeMods flags = True
181 | pkg_name `Set.member` includeMods flags = True
182 | mod_name `Set.member` includeMods flags = True
185 full_mod' = pkg_name ++ mod_name
186 -- pkg name always ends with '/', main
187 (pkg_name,mod_name) =
188 case span (/= '/') full_mod of
189 (p,'/':m) -> (p ++ ":",m)
191 _ -> error "impossible case in allowModule"
193 filterTix :: Flags -> Tix -> Tix
194 filterTix flags (Tix tixs) =
195 Tix $ filter (allowModule flags . tixModuleName) tixs
199 ------------------------------------------------------------------------------
200 -- HpcCombine specifics
202 data CombineFun = ADD | DIFF | SUB
203 deriving (Eq,Show, Read, Enum)
205 theCombineFun :: CombineFun -> Integer -> Integer -> Integer
206 theCombineFun fn = case fn of
207 ADD -> \ l r -> l + r
208 SUB -> \ l r -> max 0 (l - r)
209 DIFF -> \ g b -> if g > 0 then 0 else min 1 b
211 foldFuns :: [ (String,CombineFun) ]
212 foldFuns = [ (show comb,comb)
213 | comb <- [ADD .. SUB]
216 data PostFun = ID | INV | ZERO
217 deriving (Eq,Show, Read, Enum)
219 thePostFun :: PostFun -> Integer -> Integer
223 thePostFun ZERO _ = 0
225 postFuns :: [(String, PostFun)]
226 postFuns = [ (show pos,pos)
227 | pos <- [ID .. ZERO]
231 data MergeFun = INTERSECTION | UNION
232 deriving (Eq,Show, Read, Enum)
234 theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a
235 theMergeFun INTERSECTION = Set.intersection
236 theMergeFun UNION = Set.union
238 mergeFuns :: [(String, MergeFun)]
239 mergeFuns = [ (show pos,pos)
240 | pos <- [INTERSECTION,UNION]