1-- (c) 2007 Andy Gill
2
3module HpcFlags where
4
5import System.Console.GetOpt
6import qualified Data.Set as Set
7import Data.Char
8import Trace.Hpc.Tix
9import Trace.Hpc.Mix
10import System.Exit
11import System.FilePath
12
13data Flags = Flags
14  { outputFile          :: String
15  , includeMods         :: Set.Set String
16  , excludeMods         :: Set.Set String
17  , hpcDirs             :: [String]
18  , srcDirs             :: [String]
19  , destDir             :: String
20
21  , perModule           :: Bool
22  , decList             :: Bool
23  , xmlOutput           :: Bool
24
25  , funTotals           :: Bool
26  , altHighlight        :: Bool
27
28  , combineFun          :: CombineFun   -- tick-wise combine
29  , postFun             :: PostFun      --
30  , mergeModule         :: MergeFun     -- module-wise merge
31
32  , verbosity           :: Verbosity
33  }
34
35default_flags :: Flags
36default_flags = Flags
37  { outputFile          = "-"
38  , includeMods         = Set.empty
39  , excludeMods         = Set.empty
40  , hpcDirs             = [".hpc"]
41  , srcDirs             = []
42  , destDir             = "."
43
44  , perModule           = False
45  , decList             = False
46  , xmlOutput           = False
47
48  , funTotals           = False
49  , altHighlight        = False
50
51  , combineFun          = ADD
52  , postFun             = ID
53  , mergeModule         = INTERSECTION
54
55  , verbosity           = Normal
56  }
57
58
59data Verbosity = Silent | Normal | Verbose
60  deriving (Eq, Ord)
61
62verbosityFromString :: String -> Verbosity
63verbosityFromString "0" = Silent
64verbosityFromString "1" = Normal
65verbosityFromString "2" = Verbose
66verbosityFromString v   = error $ "unknown verbosity: " ++ v
67
68
69-- We do this after reading flags, because the defaults
70-- depends on if specific flags we used.
71
72default_final_flags :: Flags -> Flags
73default_final_flags flags = flags
74  { srcDirs = if null (srcDirs flags)
75              then ["."]
76              else srcDirs flags
77  }
78
79type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
80
81noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
82noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
83
84anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
85anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
86
87infoArg :: String -> FlagOptSeq
88infoArg info = (:) $ Option [] [] (NoArg $ id) info
89
90excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt,
91    destDirOpt, outputOpt, verbosityOpt,
92    perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
93    altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
94    mapFunOptInfo, unionModuleOpt :: FlagOptSeq
95excludeOpt      = anArg "exclude"    "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
96                $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
97
98includeOpt      = anArg "include"    "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
99                $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
100
101hpcDirOpt       = anArg "hpcdir"     "append sub-directory that contains .mix files" "DIR"
102                   (\ a f -> f { hpcDirs = hpcDirs f ++ [a] })
103                .  infoArg "default .hpc [rarely used]"
104
105resetHpcDirsOpt = noArg "reset-hpcdirs" "empty the list of hpcdir's"
106                   (\ f -> f { hpcDirs = [] })
107                .  infoArg "[rarely used]"
108
109srcDirOpt       = anArg "srcdir"     "path to source directory of .hs files" "DIR"
110                  (\ a f -> f { srcDirs = srcDirs f ++ [a] })
111                . infoArg "multi-use of srcdir possible"
112
113destDirOpt      = anArg "destdir"   "path to write output to" "DIR"
114                $ \ a f -> f { destDir = a }
115
116
117outputOpt     = anArg "output"    "output FILE" "FILE"        $ \ a f -> f { outputFile = a }
118
119verbosityOpt  = anArg "verbosity" "verbosity level, 0-2" "[0-2]"
120                (\ a f -> f { verbosity  = verbosityFromString a })
121              . infoArg "default 1"
122
123-- markup
124
125perModuleOpt  = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
126decListOpt    = noArg "decl-list"  "show unused decls"        $ \ f -> f { decList = True }
127xmlOutputOpt  = noArg "xml-output" "show output in XML"       $ \ f -> f { xmlOutput = True }
128funTotalsOpt  = noArg "fun-entry-count" "show top-level function entry counts"
129                                                              $ \ f -> f { funTotals = True }
130altHighlightOpt
131              = noArg "highlight-covered" "highlight covered code, rather that code gaps"
132                                                              $ \ f -> f { altHighlight = True }
133
134combineFunOpt = anArg "function"
135                      "combine .tix files with join function, default = ADD" "FUNCTION"
136              $ \ a f -> case reads (map toUpper a) of
137                          [(c,"")] -> f { combineFun = c }
138                          _ -> error $ "no such combine function : " ++ a
139combineFunOptInfo = infoArg
140                  $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)
141
142mapFunOpt = anArg "function"
143                      "apply function to .tix files, default = ID" "FUNCTION"
144              $ \ a f -> case reads (map toUpper a) of
145                          [(c,"")] -> f { postFun = c }
146                          _ -> error $ "no such combine function : " ++ a
147mapFunOptInfo = infoArg
148                  $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)
149
150unionModuleOpt = noArg "union"
151                      "use the union of the module namespace (default is intersection)"
152              $ \ f -> f { mergeModule = UNION }
153
154
155-------------------------------------------------------------------------------
156
157readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
158readMixWithFlags flags modu = readMix [ dir </> hpcDir
159                                      | dir <- srcDirs flags
160                                      , hpcDir <- hpcDirs flags
161                                      ] modu
162
163-------------------------------------------------------------------------------
164
165command_usage :: Plugin -> IO ()
166command_usage plugin =
167  putStrLn $
168                                       "Usage: hpc " ++ (name plugin) ++ " " ++
169                                        (usage plugin) ++
170                                        "\n" ++ summary plugin ++ "\n" ++
171                                        if null (options plugin [])
172                                        then ""
173                                        else usageInfo "\n\nOptions:\n" (options plugin [])
174
175hpcError :: Plugin -> String -> IO a
176hpcError plugin msg = do
177   putStrLn $ "Error: " ++ msg
178   command_usage plugin
179   exitFailure
180
181-------------------------------------------------------------------------------
182
183data Plugin = Plugin { name           :: String
184                     , usage          :: String
185                     , options        :: FlagOptSeq
186                     , summary        :: String
187                     , implementation :: Flags -> [String] -> IO ()
188                     , init_flags     :: Flags
189                     , final_flags    :: Flags -> Flags
190                     }
191
192------------------------------------------------------------------------------
193
194-- filterModules takes a list of candidate modules,
195-- and
196--  * excludes the excluded modules
197--  * includes the rest if there are no explicitly included modules
198--  * otherwise, accepts just the included modules.
199
200allowModule :: Flags -> String -> Bool
201allowModule flags full_mod
202      | full_mod' `Set.member` excludeMods flags = False
203      | pkg_name  `Set.member` excludeMods flags = False
204      | mod_name  `Set.member` excludeMods flags = False
205      | Set.null (includeMods flags)             = True
206      | full_mod' `Set.member` includeMods flags = True
207      | pkg_name  `Set.member` includeMods flags = True
208      | mod_name  `Set.member` includeMods flags = True
209      | otherwise                                = False
210  where
211          full_mod' = pkg_name ++ mod_name
212      -- pkg name always ends with '/', main
213          (pkg_name,mod_name) =
214                        case span (/= '/') full_mod of
215                     (p,'/':m) -> (p ++ ":",m)
216                     (m,[])    -> (":",m)
217                     _         -> error "impossible case in allowModule"
218
219filterTix :: Flags -> Tix -> Tix
220filterTix flags (Tix tixs) =
221     Tix $ filter (allowModule flags . tixModuleName) tixs
222
223
224
225------------------------------------------------------------------------------
226-- HpcCombine specifics
227
228data CombineFun = ADD | DIFF | SUB
229     deriving (Eq,Show, Read, Enum)
230
231theCombineFun :: CombineFun -> Integer -> Integer -> Integer
232theCombineFun fn = case fn of
233            ADD  -> \ l r -> l + r
234            SUB  -> \ l r -> max 0 (l - r)
235            DIFF -> \ g b -> if g > 0 then 0 else min 1 b
236
237foldFuns :: [ (String,CombineFun) ]
238foldFuns = [ (show comb,comb)
239           | comb <- [ADD .. SUB]
240           ]
241
242data PostFun = ID | INV | ZERO
243     deriving (Eq,Show, Read, Enum)
244
245thePostFun :: PostFun -> Integer -> Integer
246thePostFun ID   x = x
247thePostFun INV  0 = 1
248thePostFun INV  _ = 0
249thePostFun ZERO _ = 0
250
251postFuns :: [(String, PostFun)]
252postFuns = [ (show pos,pos)
253             | pos <- [ID .. ZERO]
254           ]
255
256
257data MergeFun = INTERSECTION | UNION
258     deriving (Eq,Show, Read, Enum)
259
260theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a
261theMergeFun INTERSECTION = Set.intersection
262theMergeFun UNION        = Set.union
263
264mergeFuns :: [(String, MergeFun)]
265mergeFuns = [ (show pos,pos)
266             | pos <- [INTERSECTION,UNION]
267           ]
268
269