X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhpc%2FHpcFlags.hs;h=b4453670236562bfb4ee34474fd5967985b4a748;hb=0843c0bdc66008008d38eff07c90437ed56d9ca1;hp=eb9a197b903c90ad4cea9546ab4a5e3b54d5928d;hpb=a966047ca5c407f336a633d716d3d7b5ed29d231;p=ghc-hetmet.git diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs index eb9a197..b445367 100644 --- a/utils/hpc/HpcFlags.hs +++ b/utils/hpc/HpcFlags.hs @@ -7,14 +7,15 @@ import Data.Maybe ( fromMaybe ) import qualified HpcSet as Set import Data.Char import Trace.Hpc.Tix +import Trace.Hpc.Mix import System.Exit data Flags = Flags { outputFile :: String , includeMods :: Set.Set String , excludeMods :: Set.Set String - , hsDirs :: [String] - , hpcDirs :: [String] + , hpcDir :: String + , srcDirs :: [String] , destDir :: String , perModule :: Bool @@ -24,16 +25,17 @@ data Flags = Flags , funTotals :: Bool , altHighlight :: Bool - , combineFun :: CombineFun - , postInvert :: Bool + , combineFun :: CombineFun -- tick-wise combine + , postFun :: PostFun -- + , mergeModule :: MergeFun -- module-wise merge } default_flags = Flags { outputFile = "-" , includeMods = Set.empty , excludeMods = Set.empty - , hpcDirs = [] - , hsDirs = [] + , hpcDir = ".hpc" + , srcDirs = [] , destDir = "." , perModule = False @@ -44,44 +46,54 @@ default_flags = Flags , altHighlight = False , combineFun = ADD - , postInvert = False + , postFun = ID + , mergeModule = INTERSECTION } + -- We do this after reading flags, because the defaults -- depends on if specific flags we used. default_final_flags flags = flags - { hpcDirs = if null (hpcDirs flags) - then [".hpc"] - else hpcDirs flags - , hsDirs = if null (hsDirs flags) + { srcDirs = if null (srcDirs flags) then ["."] - else hsDirs flags + else srcDirs flags } -noArg :: String -> String -> (Flags -> Flags) -> OptDescr (Flags -> Flags) -noArg flag detail fn = Option [] [flag] (NoArg $ fn) detail +type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)] + +noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq +noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail + +anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq +anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail + +infoArg :: String -> FlagOptSeq +infoArg info = (:) $ Option [] [] (NoArg $ id) info -anArg :: String -> String -> String -> (String -> Flags -> Flags) -> OptDescr (Flags -> Flags) -anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail +excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" + $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f } -infoArg :: String -> OptDescr (Flags -> Flags) -infoArg info = Option [] [] (NoArg $ id) info +includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" + $ \ a f -> f { includeMods = a `Set.insert` includeMods f } -excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f } +hpcDirOpt = anArg "hpcdir" "sub-directory that contains .mix files" "DIR" + (\ a f -> f { hpcDir = a }) + . infoArg "default .hpc [rarely used]" -includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { includeMods = a `Set.insert` includeMods f } -hpcDirOpt = anArg "hpcdir" "path to .mix files (default .hpc)" "DIR" - $ \ a f -> f { hpcDirs = hpcDirs f ++ [a] } -hsDirOpt = anArg "hsdir" "path to .hs files (default .)" "DIR" - $ \ a f -> f { hsDirs = hsDirs f ++ [a] } -destDirOpt = anArg "destdir" "path to write output to" "DIR" - $ \ a f -> f { destDir = a } +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 } + + outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a } -- markup perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True } -decListOpt = noArg "dec-list" "show unused decls" $ \ f -> f { decList = True } +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 } @@ -89,25 +101,44 @@ altHighlightOpt = noArg "highlight-covered" "highlight covered code, rather that code gaps" $ \ f -> f { altHighlight = True } -combineFunOpt = anArg "combine" +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 combineFuns) + $ "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 } + + +------------------------------------------------------------------------------- + +readMixWithFlags :: Flags -> Either String TixModule -> IO Mix +readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags + | dir <- srcDirs flags + ] mod -postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked" - $ \ f -> f { funTotals = True } ------------------------------------------------------------------------------- command_usage plugin = putStrLn $ "Usage: hpc " ++ (name plugin) ++ " " ++ (usage plugin) ++ - if null (options plugin) + "\n" ++ summary plugin ++ "\n" ++ + if null (options plugin []) then "" - else usageInfo "\n\nOptions:\n" (options plugin) + else usageInfo "\n\nOptions:\n" (options plugin []) hpcError :: Plugin -> String -> IO a hpcError plugin msg = do @@ -119,7 +150,7 @@ hpcError plugin msg = do data Plugin = Plugin { name :: String , usage :: String - , options :: [OptDescr (Flags -> Flags)] + , options :: FlagOptSeq , summary :: String , implementation :: Flags -> [String] -> IO () , init_flags :: Flags @@ -136,15 +167,16 @@ data Plugin = Plugin { name :: String allowModule :: Flags -> String -> Bool allowModule flags full_mod - | 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 + | 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 where + full_mod' = pkg_name ++ mod_name -- pkg name always ends with '/', main (pkg_name,mod_name) = case span (/= '/') full_mod of @@ -161,9 +193,42 @@ filterTix flags (Tix tixs) = ------------------------------------------------------------------------------ -- HpcCombine specifics -data CombineFun = ADD | DIFF | SUB | ZERO +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 + deriving (Eq,Show, Read, Enum) + +thePostFun :: PostFun -> Integer -> Integer +thePostFun ID x = x +thePostFun INV 0 = 1 +thePostFun INV n = 0 +thePostFun ZERO x = 0 + +postFuns = [ (show pos,pos) + | pos <- [ID .. ZERO] + ] + + +data MergeFun = INTERSECTION | UNION deriving (Eq,Show, Read, Enum) -combineFuns = [ (show comb,comb) - | comb <- [ADD .. ZERO] - ] +theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a +theMergeFun INTERSECTION = Set.intersection +theMergeFun UNION = Set.union + +mergeFuns = [ (show pos,pos) + | pos <- [INTERSECTION,UNION] + ] +