HpcFlags.hs 7.91 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 12 13 14 15

data Flags = Flags 
  { outputFile		:: String
  , includeMods         :: Set.Set String
  , excludeMods         :: Set.Set String
16 17
  , hpcDir		:: String
  , srcDirs		:: [String]
18 19 20 21 22 23 24 25 26
  , destDir		:: String

  , perModule 		:: Bool
  , decList 		:: Bool
  , xmlOutput 		:: Bool

  , funTotals           :: Bool
  , altHighlight        :: Bool

27 28 29
  , combineFun          :: CombineFun	-- tick-wise combine
  , postFun		:: PostFun	-- 
  , mergeModule		:: MergeFun	-- module-wise merge
30 31
  }

Ian Lynagh's avatar
Ian Lynagh committed
32
default_flags :: Flags
33 34 35 36
default_flags = Flags
  { outputFile		= "-"
  , includeMods         = Set.empty
  , excludeMods         = Set.empty
37 38
  , hpcDir              = ".hpc"
  , srcDirs             = []
39 40 41 42 43 44 45 46 47 48
  , destDir             = "."

  , perModule           = False
  , decList		= False
  , xmlOutput		= False

  , funTotals           = False
  , altHighlight        = False

  , combineFun          = ADD
49 50
  , postFun             = ID
  , mergeModule		= INTERSECTION
51 52
  }

53

54 55 56
-- We do this after reading flags, because the defaults
-- depends on if specific flags we used.

Ian Lynagh's avatar
Ian Lynagh committed
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 67
noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
68

69 70
anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
71

72 73
infoArg :: String -> FlagOptSeq
infoArg info = (:) $ Option [] [] (NoArg $ id) info
74

Ian Lynagh's avatar
Ian Lynagh committed
75 76 77 78
excludeOpt, includeOpt, hpcDirOpt, srcDirOpt, destDirOpt, outputOpt,
    perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
    altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
    mapFunOptInfo, unionModuleOpt :: FlagOptSeq
79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
excludeOpt      = anArg "exclude"    "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"  
                $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }

includeOpt      = anArg "include"    "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"  
                $ \ a f -> f { includeMods = a `Set.insert` includeMods f }

hpcDirOpt        = anArg "hpcdir"     "sub-directory that contains .mix files" "DIR"
                   (\ a f -> f { hpcDir = a })
                .  infoArg "default .hpc [rarely used]"

srcDirOpt       = anArg "srcdir"     "path to source directory of .hs files" "DIR"
	          (\ a f -> f { srcDirs = srcDirs f ++ [a] })
	        . infoArg "multi-use of srcdir possible"
	        
destDirOpt      = anArg "destdir"   "path to write output to" "DIR"
	        $ \ a f -> f { destDir = a }

	        
97 98 99 100
outputOpt     = anArg "output"    "output FILE" "FILE"        $ \ a f -> f { outputFile = a }
-- markup

perModuleOpt  = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
101
decListOpt    = noArg "decl-list"  "show unused decls"	      $ \ f -> f { decList = True }
102 103 104 105 106 107 108
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 }  

109
combineFunOpt = anArg "function" 
110 111 112 113 114
	      	      "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 
115 116 117 118 119 120 121 122 123 124 125 126 127 128
		  $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)

mapFunOpt = anArg "function"
	      	      "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)

unionModuleOpt = noArg "union"
	      	      "use the union of the module namespace (default is intersection)"
	      $ \ f -> f { mergeModule = UNION }

129 130 131

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

andy@galois.com's avatar
andy@galois.com committed
132
readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
Ian Lynagh's avatar
Ian Lynagh committed
133 134 135
readMixWithFlags flags modu = readMix [ dir ++  "/" ++ hpcDir flags
                                      | dir <- srcDirs flags 
                                      ] modu
136 137 138

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

Ian Lynagh's avatar
Ian Lynagh committed
139
command_usage :: Plugin -> IO ()
140 141 142 143
command_usage plugin = 
  putStrLn $
				       "Usage: hpc " ++ (name plugin) ++ " " ++ 
				        (usage plugin) ++
144
				        "\n" ++ summary plugin ++ "\n" ++
145
				        if null (options plugin [])
146
				        then ""
147
  	                                else usageInfo "\n\nOptions:\n" (options plugin [])
148

149 150 151 152 153 154
hpcError :: Plugin -> String -> IO a
hpcError plugin msg = do
   putStrLn $ "Error: " ++ msg
   command_usage plugin
   exitFailure
 
155 156 157 158
-------------------------------------------------------------------------------

data Plugin = Plugin { name           :: String
     	             , usage          :: String
159
		     , options        :: FlagOptSeq
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
		     , summary        :: String
		     , implementation :: Flags -> [String] -> IO ()
		     , init_flags     :: Flags
		     , final_flags    :: Flags -> Flags
		     }

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

-- filterModules takes a list of candidate modules, 
-- and 
--  * excludes the excluded modules
--  * includes the rest if there are no explicity included modules
--  * otherwise, accepts just the included modules.

allowModule :: Flags -> String -> Bool
175
allowModule flags full_mod 
176 177 178 179 180 181 182 183
      | 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
      | otherwise	 	       	         = False
184
  where
185
          full_mod' = pkg_name ++ mod_name
186 187
      -- pkg name always ends with '/', main 
	  (pkg_name,mod_name) = 
andy@galois.com's avatar
andy@galois.com committed
188 189
			case span (/= '/') full_mod of
		     (p,'/':m) -> (p ++ ":",m)
190 191
		     (m,[])    -> (":",m)
		     _         -> error "impossible case in allowModule" 
192 193 194 195 196

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

andy@galois.com's avatar
andy@galois.com committed
197 198
         

199 200 201
------------------------------------------------------------------------------
-- HpcCombine specifics 

202 203 204 205 206 207 208 209 210 211 212 213 214 215 216
data CombineFun = ADD | DIFF | SUB 
     deriving (Eq,Show, Read, Enum)

theCombineFun :: CombineFun -> Integer -> Integer -> Integer
theCombineFun fn = case fn of
      	    ADD  -> \ l r -> l + r
            SUB  -> \ l r -> max 0 (l - r)
	    DIFF -> \ g b -> if g > 0 then 0 else min 1 b

foldFuns :: [ (String,CombineFun) ]
foldFuns = [ (show comb,comb) 
	   | comb <- [ADD .. SUB]
	   ]

data PostFun = ID | INV | ZERO
217 218
     deriving (Eq,Show, Read, Enum)

219 220 221
thePostFun :: PostFun -> Integer -> Integer
thePostFun ID   x = x
thePostFun INV  0 = 1
Ian Lynagh's avatar
Ian Lynagh committed
222 223
thePostFun INV  _ = 0
thePostFun ZERO _ = 0
224

Ian Lynagh's avatar
Ian Lynagh committed
225
postFuns :: [(String, PostFun)]
226
postFuns = [ (show pos,pos) 
227
	     | pos <- [ID .. ZERO]
228 229 230 231 232 233 234 235 236 237
	   ]


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
238
mergeFuns :: [(String, MergeFun)]
239 240 241 242
mergeFuns = [ (show pos,pos) 
	     | pos <- [INTERSECTION,UNION]
	   ]