-- Andy Gill, Oct 2006
---------------------------------------------------------
-module HpcCombine (combine_plugin) where
+module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
import Trace.Hpc.Tix
import Trace.Hpc.Util
import System.Environment
------------------------------------------------------------------------------
+sum_options
+ = excludeOpt
+ . includeOpt
+ . outputOpt
+ . unionModuleOpt
+
+sum_plugin = Plugin { name = "sum"
+ , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
+ , options = sum_options
+ , summary = "Sum multiple .tix files in a single .tix file"
+ , implementation = sum_main
+ , init_flags = default_flags
+ , final_flags = default_final_flags
+ }
+
combine_options
= excludeOpt
. includeOpt
. outputOpt
. combineFunOpt
. combineFunOptInfo
- . postInvertOpt
-
+ . unionModuleOpt
+
combine_plugin = Plugin { name = "combine"
- , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
+ , usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
, options = combine_options
- , summary = "Combine multiple .tix files in a single .tix files"
+ , summary = "Combine two .tix files in a single .tix file"
, implementation = combine_main
, init_flags = default_flags
, final_flags = default_final_flags
}
-------------------------------------------------------------------------------
+map_options
+ = excludeOpt
+ . includeOpt
+ . outputOpt
+ . mapFunOpt
+ . mapFunOptInfo
+ . unionModuleOpt
-combine_main :: Flags -> [String] -> IO ()
-combine_main flags (first_file:more_files) = do
- -- combine does not expand out the .tix filenames (by design).
+map_plugin = Plugin { name = "map"
+ , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
+ , options = map_options
+ , summary = "Map a function over a single .tix file"
+ , implementation = map_main
+ , init_flags = default_flags
+ , final_flags = default_final_flags
+ }
- let f = case combineFun flags 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
- ZERO -> \ _ _ -> 0
+------------------------------------------------------------------------------
+sum_main :: Flags -> [String] -> IO ()
+sum_main flags [] = hpcError sum_plugin $ "no .tix file specified"
+sum_main flags (first_file:more_files) = do
Just tix <- readTix first_file
- tix' <- foldM (mergeTixFile flags f)
+ tix' <- foldM (mergeTixFile flags (+))
(filterTix flags tix)
more_files
- let (Tix inside_tix') = tix'
- let inv 0 = 1
- inv n = 0
- let tix'' = if postInvert flags
- then Tix [ TixModule m p i (map inv t)
- | TixModule m p i t <- inside_tix'
- ]
- else tix'
+ case outputFile flags of
+ "-" -> putStrLn (show tix')
+ out -> writeTix out tix'
+
+combine_main :: Flags -> [String] -> IO ()
+combine_main flags [first_file,second_file] = do
+ let f = theCombineFun (combineFun flags)
+
+ Just tix1 <- readTix first_file
+ Just tix2 <- readTix second_file
+
+ let tix = mergeTix (mergeModule flags)
+ f
+ (filterTix flags tix1)
+ (filterTix flags tix2)
+
+ case outputFile flags of
+ "-" -> putStrLn (show tix)
+ out -> writeTix out tix
+combine_main flags [] = hpcError sum_plugin $ "need exactly two .tix files to combine"
+
+map_main :: Flags -> [String] -> IO ()
+map_main flags [first_file] = do
+ let f = thePostFun (postFun flags)
+
+ Just tix <- readTix first_file
+
+ let (Tix inside_tix) = filterTix flags tix
+ let tix' = Tix [ TixModule m p i (map f t)
+ | TixModule m p i t <- inside_tix
+ ]
case outputFile flags of
- "-" -> putStrLn (show tix'')
- out -> writeTix out tix''
+ "-" -> putStrLn (show tix')
+ out -> writeTix out tix'
+map_main flags [] = hpcError sum_plugin $ "no .tix file specified"
+map_main flags _ = hpcError sum_plugin $ "to many .tix files specified"
mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
mergeTixFile flags fn tix file_name = do
Just new_tix <- readTix file_name
- return $! strict $ mergeTix fn tix (filterTix flags new_tix)
+ return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix)
-- could allow different numbering on the module info,
-- as long as the total is the same; will require normalization.
-mergeTix :: (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
-mergeTix f
+mergeTix :: MergeFun
+ -> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
+mergeTix modComb f
(Tix t1)
(Tix t2) = Tix
[ case (Map.lookup m fm1,Map.lookup m fm2) of
-> error $ "mismatched in module " ++ m
| otherwise ->
TixModule m hash1 len1 (zipWith f tix1 tix2)
- (Just (TixModule _ hash1 len1 tix1),Nothing) ->
- error $ "rogue module " ++ show m
- (Nothing,Just (TixModule _ hash2 len2 tix2)) ->
- error $ "rogue module " ++ show m
+ (Just m1,Nothing) ->
+ m1
+ (Nothing,Just m2) ->
+ m2
_ -> error "impossible"
- | m <- Set.toList (m1s `Set.intersection` m2s)
+ | m <- Set.toList (theMergeFun modComb m1s m2s)
]
where
m1s = Set.fromList $ map tixModuleName t1
, funTotals :: Bool
, altHighlight :: Bool
- , combineFun :: CombineFun
- , postInvert :: Bool
+ , combineFun :: CombineFun -- tick-wise combine
+ , postFun :: PostFun --
+ , mergeModule :: MergeFun -- module-wise merge
}
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.
= 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 }
+
-postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
- $ \ f -> f { funTotals = True }
-------------------------------------------------------------------------------
readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
putStrLn $
"Usage: hpc " ++ (name plugin) ++ " " ++
(usage plugin) ++
+ "\n" ++ summary plugin ++ "\n" ++
if null (options plugin [])
then ""
else usageInfo "\n\nOptions:\n" (options plugin [])
------------------------------------------------------------------------------
-- 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)
-combineFuns = [ (show comb,comb)
- | comb <- [ADD .. ZERO]
- ]
+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 <- [INV .. ZERO]
+ ]
+
+
+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
+
+mergeFuns = [ (show pos,pos)
+ | pos <- [INTERSECTION,UNION]
+ ]
+
projects / ghc-hetmet.git / commitdiff