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 Trace.Hpc.Mix
  11 import System.Exit
  12
  13 data Flags = Flags
  14   { outputFile          :: String
  15   , includeMods         :: Set.Set String
  16   , excludeMods         :: Set.Set String
  17   , hpcDir              :: 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
  29   , postInvert          :: Bool
  30   }
  31
  32 default_flags = Flags
  33   { outputFile          = "-"
  34   , includeMods         = Set.empty
  35   , excludeMods         = Set.empty
  36   , hpcDir              = ".hpc"
  37   , srcDirs             = []
  38   , destDir             = "."
  39
  40   , perModule           = False
  41   , decList             = False
  42   , xmlOutput           = False
  43
  44   , funTotals           = False
  45   , altHighlight        = False
  46
  47   , combineFun          = ADD
  48   , postInvert          = False
  49   }
  50
  51 -- We do this after reading flags, because the defaults
  52 -- depends on if specific flags we used.
  53
  54 default_final_flags flags = flags
  55   { srcDirs = if null (srcDirs flags)
  56               then ["."]
  57               else srcDirs flags
  58   }
  59
  60 type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
  61
  62 noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
  63 noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
  64
  65 anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
  66 anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
  67
  68 infoArg :: String -> FlagOptSeq
  69 infoArg info = (:) $ Option [] [] (NoArg $ id) info
  70
  71 excludeOpt      = anArg "exclude"    "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
  72                 $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
  73
  74 includeOpt      = anArg "include"    "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
  75                 $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
  76
  77 hpcDirOpt        = anArg "hpcdir"     "sub-directory that contains .mix files" "DIR"
  78                    (\ a f -> f { hpcDir = a })
  79                 .  infoArg "default .hpc [rarely used]"
  80
  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"
  84
  85 destDirOpt      = anArg "destdir"   "path to write output to" "DIR"
  86                 $ \ a f -> f { destDir = a }
  87
  88
  89 outputOpt     = anArg "output"    "output FILE" "FILE"        $ \ a f -> f { outputFile = a }
  90 -- markup
  91
  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 }
  97 altHighlightOpt
  98               = noArg "highlight-covered" "highlight covered code, rather that code gaps"
  99                                                               $ \ f -> f { altHighlight = True }
 100
 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)
 108
 109 postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
 110                                                               $ \ f -> f { funTotals = True }
 111 -------------------------------------------------------------------------------
 112
 113 readMixWithFlags flags mod = readMix [ dir ++  "/" ++ hpcDir flags
 114                                      | dir <- srcDirs flags
 115                                      ] mod
 116
 117 -------------------------------------------------------------------------------
 118
 119 command_usage plugin =
 120   putStrLn $
 121                                        "Usage: hpc " ++ (name plugin) ++ " " ++
 122                                         (usage plugin) ++
 123                                         if null (options plugin [])
 124                                         then ""
 125                                         else usageInfo "\n\nOptions:\n" (options plugin [])
 126
 127 hpcError :: Plugin -> String -> IO a
 128 hpcError plugin msg = do
 129    putStrLn $ "Error: " ++ msg
 130    command_usage plugin
 131    exitFailure
 132
 133 -------------------------------------------------------------------------------
 134
 135 data Plugin = Plugin { name           :: String
 136                      , usage          :: String
 137                      , options        :: FlagOptSeq
 138                      , summary        :: String
 139                      , implementation :: Flags -> [String] -> IO ()
 140                      , init_flags     :: Flags
 141                      , final_flags    :: Flags -> Flags
 142                      }
 143
 144 ------------------------------------------------------------------------------
 145
 146 -- filterModules takes a list of candidate modules,
 147 -- and
 148 --  * excludes the excluded modules
 149 --  * includes the rest if there are no explicity included modules
 150 --  * otherwise, accepts just the included modules.
 151
 152 allowModule :: Flags -> String -> Bool
 153 allowModule flags full_mod
 154       | full_mod' `Set.member` excludeMods flags = False
 155       | pkg_name  `Set.member` excludeMods flags = False
 156       | mod_name  `Set.member` excludeMods flags = False
 157       | Set.null (includeMods flags)             = True
 158       | full_mod' `Set.member` includeMods flags = True
 159       | pkg_name  `Set.member` includeMods flags = True
 160       | mod_name  `Set.member` includeMods flags = True
 161       | otherwise                                = False
 162   where
 163           full_mod' = pkg_name ++ mod_name
 164       -- pkg name always ends with '/', main
 165           (pkg_name,mod_name) =
 166                         case span (/= '/') full_mod of
 167                      (p,'/':m) -> (p ++ ":",m)
 168                      (m,[])    -> (":",m)
 169                      _         -> error "impossible case in allowModule"
 170
 171 filterTix :: Flags -> Tix -> Tix
 172 filterTix flags (Tix tixs) =
 173      Tix $ filter (allowModule flags . tixModuleName) tixs
 174
 175
 176
 177 ------------------------------------------------------------------------------
 178 -- HpcCombine specifics
 179
 180 data CombineFun = ADD | DIFF | SUB | ZERO
 181      deriving (Eq,Show, Read, Enum)
 182
 183 combineFuns = [ (show comb,comb)
 184               | comb <- [ADD .. ZERO]
 185               ]