HpcFlags.hs 9.38 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
import System.FilePath
12

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

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

  , funTotals           :: Bool
  , altHighlight        :: Bool

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

  , verbosity           :: Verbosity
33 34
  }

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

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

  , funTotals           = False
  , altHighlight        = False

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

  , verbosity           = Normal
56 57
  }

58

59 60 61 62 63 64 65 66 67 68
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


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

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

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

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

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

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

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

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

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

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

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

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

116

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

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

123 124 125
-- markup

perModuleOpt  = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
ian@well-typed.com's avatar
ian@well-typed.com committed
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
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)
141 142

mapFunOpt = anArg "function"
ian@well-typed.com's avatar
ian@well-typed.com committed
143 144 145 146 147 148
                      "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)
149 150

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

154 155 156

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

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

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

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

175 176 177 178 179
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
180

181 182 183
-------------------------------------------------------------------------------

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

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

ian@well-typed.com's avatar
ian@well-typed.com committed
194 195
-- filterModules takes a list of candidate modules,
-- and
196 197 198 199 200
--  * 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
201
allowModule flags full_mod
202 203 204 205 206 207 208
      | 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
209
      | otherwise                                = False
210
  where
211
          full_mod' = pkg_name ++ mod_name
ian@well-typed.com's avatar
ian@well-typed.com committed
212 213 214 215 216 217
      -- 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"
218 219 220 221 222

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
223

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

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

ian@well-typed.com's avatar
ian@well-typed.com committed
228
data CombineFun = ADD | DIFF | SUB
229 230 231 232
     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
233
            ADD  -> \ l r -> l + r
234
            SUB  -> \ l r -> max 0 (l - r)
ian@well-typed.com's avatar
ian@well-typed.com committed
235
            DIFF -> \ g b -> if g > 0 then 0 else min 1 b
236 237

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

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

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

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


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
264
mergeFuns :: [(String, MergeFun)]
ian@well-typed.com's avatar
ian@well-typed.com committed
265 266 267
mergeFuns = [ (show pos,pos)
             | pos <- [INTERSECTION,UNION]
           ]
268