utils/hpc/HpcFlags.hs

   1 -- (c) 2007 Andy Gill
   2
   3 module HpcFlags where
   4
   5 import System.Console.GetOpt
   6 import Data.Maybe ( fromMaybe )
   7 import qualified Data.Set as Set
   8 import Data.Char
   9 import Trace.Hpc.Tix
  10
  11 data Flags = Flags
  12   { outputFile          :: String
  13   , includeMods         :: Set.Set String
  14   , excludeMods         :: Set.Set String
  15   , hsDirs              :: [String]
  16   , hpcDirs             :: [String]
  17   , destDir             :: String
  18
  19   , perModule           :: Bool
  20   , decList             :: Bool
  21   , xmlOutput           :: Bool
  22
  23   , funTotals           :: Bool
  24   , altHighlight        :: Bool
  25
  26   , combineFun          :: CombineFun
  27   , postInvert          :: Bool
  28   }
  29
  30 default_flags = Flags
  31   { outputFile          = "-"
  32   , includeMods         = Set.empty
  33   , excludeMods         = Set.empty
  34   , hpcDirs             = []
  35   , hsDirs              = []
  36   , destDir             = "."
  37
  38   , perModule           = False
  39   , decList             = False
  40   , xmlOutput           = False
  41
  42   , funTotals           = False
  43   , altHighlight        = False
  44
  45   , combineFun          = ADD
  46   , postInvert          = False
  47   }
  48
  49 -- We do this after reading flags, because the defaults
  50 -- depends on if specific flags we used.
  51
  52 default_final_flags flags = flags
  53   { hpcDirs = if null (hpcDirs flags)
  54               then [".hpc"]
  55               else hpcDirs flags
  56   , hsDirs = if null (hsDirs flags)
  57               then ["."]
  58               else hsDirs flags
  59   }
  60
  61 noArg :: String -> String -> (Flags -> Flags) -> OptDescr (Flags -> Flags)
  62 noArg flag detail fn = Option [] [flag] (NoArg $ fn) detail
  63
  64 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> OptDescr (Flags -> Flags)
  65 anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail
  66
  67 infoArg :: String -> OptDescr (Flags -> Flags)
  68 infoArg info = Option [] [] (NoArg $ id) info
  69
  70 excludeOpt    = anArg "exclude"    "exclude MODULE" "MODULE"  $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
  71
  72 includeOpt    = anArg "include"    "include MODULE" "MODULE"  $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
  73 hpcDirOpt     = anArg "hpcdir"     "path to .mix files (default .hpc)" "DIR"
  74                                                               $ \ a f -> f { hpcDirs = hpcDirs f ++ [a] }
  75 hsDirOpt      = anArg "hsdir"     "path to .hs files (default .)" "DIR"
  76                                                               $ \ a f -> f { hsDirs = hsDirs f ++ [a] }
  77 destDirOpt    = anArg "destdir"   "path to write output to" "DIR"
  78                                                               $ \ a f -> f { destDir = a }
  79 outputOpt     = anArg "output"    "output FILE" "FILE"        $ \ a f -> f { outputFile = a }
  80 -- markup
  81
  82 perModuleOpt  = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
  83 decListOpt    = noArg "dec-list"   "show unused decls"        $ \ f -> f { decList = True }
  84 xmlOutputOpt  = noArg "xml-output" "show output in XML"       $ \ f -> f { xmlOutput = True }
  85 funTotalsOpt  = noArg "fun-entry-count" "show top-level function entry counts"
  86                                                               $ \ f -> f { funTotals = True }
  87 altHighlightOpt
  88               = noArg "highlight-covered" "highlight covered code, rather that code gaps"
  89                                                               $ \ f -> f { altHighlight = True }
  90
  91 combineFunOpt = anArg "combine"
  92                       "combine .tix files with join function, default = ADD" "FUNCTION"
  93               $ \ a f -> case reads (map toUpper a) of
  94                           [(c,"")] -> f { combineFun = c }
  95                           _ -> error $ "no such combine function : " ++ a
  96 combineFunOptInfo = infoArg
  97                   $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst combineFuns)
  98
  99 postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
 100                                                               $ \ f -> f { funTotals = True }
 101 -------------------------------------------------------------------------------
 102
 103 command_usage plugin =
 104   putStrLn $
 105                                        "Usage: hpc " ++ (name plugin) ++ " " ++
 106                                         (usage plugin) ++
 107                                         if null (options plugin)
 108                                         then ""
 109                                         else usageInfo "\n\nOptions:\n" (options plugin)
 110
 111 -------------------------------------------------------------------------------
 112
 113 data Plugin = Plugin { name           :: String
 114                      , usage          :: String
 115                      , options        :: [OptDescr (Flags -> Flags)]
 116                      , summary        :: String
 117                      , implementation :: Flags -> [String] -> IO ()
 118                      , init_flags     :: Flags
 119                      , final_flags    :: Flags -> Flags
 120                      }
 121
 122 ------------------------------------------------------------------------------
 123
 124 -- filterModules takes a list of candidate modules,
 125 -- and
 126 --  * excludes the excluded modules
 127 --  * includes the rest if there are no explicity included modules
 128 --  * otherwise, accepts just the included modules.
 129
 130 allowModule :: Flags -> String -> Bool
 131 allowModule flags mod
 132       | mod `Set.member` excludeMods flags = False
 133       | Set.null (includeMods flags)       = True
 134       | mod `Set.member` includeMods flags = True
 135       | otherwise                          = False
 136
 137 filterTix :: Flags -> Tix -> Tix
 138 filterTix flags (Tix tixs) =
 139      Tix $ filter (allowModule flags . tixModuleName) tixs
 140
 141 ------------------------------------------------------------------------------
 142 -- HpcCombine specifics
 143
 144 data CombineFun = ADD | DIFF | SUB | ZERO
 145      deriving (Eq,Show, Read, Enum)
 146
 147 combineFuns = [ (show comb,comb)
 148               | comb <- [ADD .. ZERO]
 149               ]