HpcFlags.hs 9.36 KB
Newer Older
1 2 3 4 5
-- (c) 2007 Andy Gill

module HpcFlags where

import System.Console.GetOpt
6
import qualified Data.Set as Set
7 8
import Data.Char
import Trace.Hpc.Tix
9
import Trace.Hpc.Mix
10
import System.Exit
11

ian@well-typed.com's avatar
ian@well-typed.com committed
12 13
data Flags = Flags
  { outputFile          :: String
14 15
  , includeMods         :: Set.Set String
  , excludeMods         :: Set.Set String
16
  , hpcDirs             :: [String]
ian@well-typed.com's avatar
ian@well-typed.com committed
17 18
  , srcDirs             :: [String]
  , destDir             :: String
19

ian@well-typed.com's avatar
ian@well-typed.com committed
20 21 22
  , perModule           :: Bool
  , decList             :: Bool
  , xmlOutput           :: Bool
23 24 25 26

  , funTotals           :: Bool
  , altHighlight        :: Bool

ian@well-typed.com's avatar
ian@well-typed.com committed
27 28 29
  , combineFun          :: CombineFun   -- tick-wise combine
  , postFun             :: PostFun      --
  , mergeModule         :: MergeFun     -- module-wise merge
30 31

  , verbosity           :: Verbosity
32 33
  }

Ian Lynagh's avatar
Ian Lynagh committed
34
default_flags :: Flags
35
default_flags = Flags
ian@well-typed.com's avatar
ian@well-typed.com committed
36
  { outputFile          = "-"
37 38
  , includeMods         = Set.empty
  , excludeMods         = Set.empty
39
  , hpcDirs             = [".hpc"]
40
  , srcDirs             = []
41 42 43
  , destDir             = "."

  , perModule           = False
ian@well-typed.com's avatar
ian@well-typed.com committed
44 45
  , decList             = False
  , xmlOutput           = False
46 47 48 49 50

  , funTotals           = False
  , altHighlight        = False

  , combineFun          = ADD
51
  , postFun             = ID
ian@well-typed.com's avatar
ian@well-typed.com committed
52
  , mergeModule         = INTERSECTION
53 54

  , verbosity           = Normal
55 56
  }

57

58 59 60 61 62 63 64 65 66 67
data Verbosity = Silent | Normal | Verbose
  deriving (Eq, Ord)

verbosityFromString :: String -> Verbosity
verbosityFromString "0" = Silent
verbosityFromString "1" = Normal
verbosityFromString "2" = Verbose
verbosityFromString v   = error $ "unknown verbosity: " ++ v


68 69 70
-- We do this after reading flags, because the defaults
-- depends on if specific flags we used.

Ian Lynagh's avatar
Ian Lynagh committed
71
default_final_flags :: Flags -> Flags
ian@well-typed.com's avatar
ian@well-typed.com committed
72
default_final_flags flags = flags
73
  { srcDirs = if null (srcDirs flags)
ian@well-typed.com's avatar
ian@well-typed.com committed
74 75
              then ["."]
              else srcDirs flags
76 77
  }

78
type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
79

80 81
noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
82

83 84
anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
85

86 87
infoArg :: String -> FlagOptSeq
infoArg info = (:) $ Option [] [] (NoArg $ id) info
88

89
excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt,
90
    destDirOpt, outputOpt, verbosityOpt,
Ian Lynagh's avatar
Ian Lynagh committed
91 92 93
    perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
    altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
    mapFunOptInfo, unionModuleOpt :: FlagOptSeq
ian@well-typed.com's avatar
ian@well-typed.com committed
94
excludeOpt      = anArg "exclude"    "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
95 96
                $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }

ian@well-typed.com's avatar
ian@well-typed.com committed
97
includeOpt      = anArg "include"    "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
98 99
                $ \ a f -> f { includeMods = a `Set.insert` includeMods f }

100 101
hpcDirOpt       = anArg "hpcdir"     "append sub-directory that contains .mix files" "DIR"
                   (\ a f -> f { hpcDirs = hpcDirs f ++ [a] })
102 103
                .  infoArg "default .hpc [rarely used]"

104 105 106 107
resetHpcDirsOpt = noArg "reset-hpcdirs" "empty the list of hpcdir's"
                   (\ f -> f { hpcDirs = [] })
                .  infoArg "[rarely used]"

108
srcDirOpt       = anArg "srcdir"     "path to source directory of .hs files" "DIR"
ian@well-typed.com's avatar
ian@well-typed.com committed
109 110 111
                  (\ a f -> f { srcDirs = srcDirs f ++ [a] })
                . infoArg "multi-use of srcdir possible"

112
destDirOpt      = anArg "destdir"   "path to write output to" "DIR"
ian@well-typed.com's avatar
ian@well-typed.com committed
113 114
                $ \ a f -> f { destDir = a }

115

116
outputOpt     = anArg "output"    "output FILE" "FILE"        $ \ a f -> f { outputFile = a }
117 118 119 120 121

verbosityOpt  = anArg "verbosity" "verbosity level, 0-2" "[0-2]"
                (\ a f -> f { verbosity  = verbosityFromString a })
              . infoArg "default 1"

122 123 124
-- markup

perModuleOpt  = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
ian@well-typed.com's avatar
ian@well-typed.com committed
125 126 127 128 129 130 131 132 133 134 135 136 137 138 139
decListOpt    = noArg "decl-list"  "show unused decls"        $ \ f -> f { decList = True }
xmlOutputOpt  = noArg "xml-output" "show output in XML"       $ \ f -> f { xmlOutput = True }
funTotalsOpt  = noArg "fun-entry-count" "show top-level function entry counts"
                                                              $ \ f -> f { funTotals = True }
altHighlightOpt
              = noArg "highlight-covered" "highlight covered code, rather that code gaps"
                                                              $ \ f -> f { altHighlight = True }

combineFunOpt = anArg "function"
                      "combine .tix files with join function, default = ADD" "FUNCTION"
              $ \ a f -> case reads (map toUpper a) of
                          [(c,"")] -> f { combineFun = c }
                          _ -> error $ "no such combine function : " ++ a
combineFunOptInfo = infoArg
                  $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)
140 141

mapFunOpt = anArg "function"
ian@well-typed.com's avatar
ian@well-typed.com committed
142 143 144 145 146 147
                      "apply function to .tix files, default = ID" "FUNCTION"
              $ \ a f -> case reads (map toUpper a) of
                          [(c,"")] -> f { postFun = c }
                          _ -> error $ "no such combine function : " ++ a
mapFunOptInfo = infoArg
                  $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)
148 149

unionModuleOpt = noArg "union"
ian@well-typed.com's avatar
ian@well-typed.com committed
150 151
                      "use the union of the module namespace (default is intersection)"
              $ \ f -> f { mergeModule = UNION }
152

153 154 155

-------------------------------------------------------------------------------

andy@galois.com's avatar
andy@galois.com committed
156
readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
157
readMixWithFlags flags modu = readMix [ dir ++  "/" ++ hpcDir
ian@well-typed.com's avatar
ian@well-typed.com committed
158
                                      | dir <- srcDirs flags
159
                                      , hpcDir <- hpcDirs flags
Ian Lynagh's avatar
Ian Lynagh committed
160
                                      ] modu
161 162 163

-------------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
164
command_usage :: Plugin -> IO ()
ian@well-typed.com's avatar
ian@well-typed.com committed
165
command_usage plugin =
166
  putStrLn $
ian@well-typed.com's avatar
ian@well-typed.com committed
167 168 169 170 171 172
                                       "Usage: hpc " ++ (name plugin) ++ " " ++
                                        (usage plugin) ++
                                        "\n" ++ summary plugin ++ "\n" ++
                                        if null (options plugin [])
                                        then ""
                                        else usageInfo "\n\nOptions:\n" (options plugin [])
173

174 175 176 177 178
hpcError :: Plugin -> String -> IO a
hpcError plugin msg = do
   putStrLn $ "Error: " ++ msg
   command_usage plugin
   exitFailure
ian@well-typed.com's avatar
ian@well-typed.com committed
179

180 181 182
-------------------------------------------------------------------------------

data Plugin = Plugin { name           :: String
ian@well-typed.com's avatar
ian@well-typed.com committed
183 184 185 186 187 188 189
                     , usage          :: String
                     , options        :: FlagOptSeq
                     , summary        :: String
                     , implementation :: Flags -> [String] -> IO ()
                     , init_flags     :: Flags
                     , final_flags    :: Flags -> Flags
                     }
190 191 192

------------------------------------------------------------------------------

ian@well-typed.com's avatar
ian@well-typed.com committed
193 194
-- filterModules takes a list of candidate modules,
-- and
195 196 197 198 199
--  * excludes the excluded modules
--  * includes the rest if there are no explicity included modules
--  * otherwise, accepts just the included modules.

allowModule :: Flags -> String -> Bool
ian@well-typed.com's avatar
ian@well-typed.com committed
200
allowModule flags full_mod
201 202 203 204 205 206 207
      | full_mod' `Set.member` excludeMods flags = False
      | pkg_name  `Set.member` excludeMods flags = False
      | mod_name  `Set.member` excludeMods flags = False
      | Set.null (includeMods flags)             = True
      | full_mod' `Set.member` includeMods flags = True
      | pkg_name  `Set.member` includeMods flags = True
      | mod_name  `Set.member` includeMods flags = True
ian@well-typed.com's avatar
ian@well-typed.com committed
208
      | otherwise                                = False
209
  where
210
          full_mod' = pkg_name ++ mod_name
ian@well-typed.com's avatar
ian@well-typed.com committed
211 212 213 214 215 216
      -- pkg name always ends with '/', main
          (pkg_name,mod_name) =
                        case span (/= '/') full_mod of
                     (p,'/':m) -> (p ++ ":",m)
                     (m,[])    -> (":",m)
                     _         -> error "impossible case in allowModule"
217 218 219 220 221

filterTix :: Flags -> Tix -> Tix
filterTix flags (Tix tixs) =
     Tix $ filter (allowModule flags . tixModuleName) tixs

ian@well-typed.com's avatar
ian@well-typed.com committed
222

andy@galois.com's avatar
andy@galois.com committed
223

224
------------------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
225
-- HpcCombine specifics
226

ian@well-typed.com's avatar
ian@well-typed.com committed
227
data CombineFun = ADD | DIFF | SUB
228 229 230 231
     deriving (Eq,Show, Read, Enum)

theCombineFun :: CombineFun -> Integer -> Integer -> Integer
theCombineFun fn = case fn of
ian@well-typed.com's avatar
ian@well-typed.com committed
232
            ADD  -> \ l r -> l + r
233
            SUB  -> \ l r -> max 0 (l - r)
ian@well-typed.com's avatar
ian@well-typed.com committed
234
            DIFF -> \ g b -> if g > 0 then 0 else min 1 b
235 236

foldFuns :: [ (String,CombineFun) ]
ian@well-typed.com's avatar
ian@well-typed.com committed
237 238 239
foldFuns = [ (show comb,comb)
           | comb <- [ADD .. SUB]
           ]
240 241

data PostFun = ID | INV | ZERO
242 243
     deriving (Eq,Show, Read, Enum)

244 245 246
thePostFun :: PostFun -> Integer -> Integer
thePostFun ID   x = x
thePostFun INV  0 = 1
Ian Lynagh's avatar
Ian Lynagh committed
247 248
thePostFun INV  _ = 0
thePostFun ZERO _ = 0
249

Ian Lynagh's avatar
Ian Lynagh committed
250
postFuns :: [(String, PostFun)]
ian@well-typed.com's avatar
ian@well-typed.com committed
251 252 253
postFuns = [ (show pos,pos)
             | pos <- [ID .. ZERO]
           ]
254 255 256 257 258 259 260 261 262


data MergeFun = INTERSECTION | UNION
     deriving (Eq,Show, Read, Enum)

theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a
theMergeFun INTERSECTION = Set.intersection
theMergeFun UNION        = Set.union

Ian Lynagh's avatar
Ian Lynagh committed
263
mergeFuns :: [(String, MergeFun)]
ian@well-typed.com's avatar
ian@well-typed.com committed
264 265 266
mergeFuns = [ (show pos,pos)
             | pos <- [INTERSECTION,UNION]
           ]
267