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