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