utils/hpc/HpcFlags.hs

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