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
, 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
, 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 }
= 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
data Plugin = Plugin { name :: String
, usage :: String
- , options :: [OptDescr (Flags -> Flags)]
+ , options :: FlagOptSeq
, summary :: String
, implementation :: Flags -> [String] -> IO ()
, init_flags :: Flags
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
------------------------------------------------------------------------------
-- 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]
+ ]
+
projects / ghc-hetmet.git / blobdiff