Improving the combine mode for hpc

we now have
Processing Coverage files:
  sum         Sum multiple .tix files in a single .tix file
  combine     Combine two .tix files in a single .tix file
  map         Map a function over a single .tix file

Where sum joins many .tix files, combine joins two files (with
extra functionality possible), and map just applied a function
to single .tix file.

These changes were improvements driven by hpc use cases.

END OF DESCRIPTION***

Place the long patch description above the ***END OF DESCRIPTION*** marker.
The first line of this file will be the patch name.


This patch contains the following changes:

M ./utils/hpc/Hpc.hs -1 +3
M ./utils/hpc/HpcCombine.hs -33 +84
M ./utils/hpc/HpcFlags.hs -11 +59

3 files changed, 146 insertions, 45 deletions

diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs
index 524dfe508b..68fe87f98b 100644
--- a/utils/hpc/Hpc.hs
+++ b/utils/hpc/Hpc.hs
@@ -28,7 +28,7 @@ helpList =
     help       = ["help"]
     reporting  = ["report","markup"]
     overlays   = ["overlay","draft"]
-    processing = ["combine"]
+    processing = ["sum","combine","map"]
     other     = [ name hook
     	        | hook <- hooks
 		, name hook `notElem` 
@@ -77,7 +77,9 @@ main = do
 hooks = [ help_plugin
         , report_plugin 
 	, markup_plugin
+	, sum_plugin
 	, combine_plugin
+	, map_plugin
 	, showtix_plugin
 	, overlay_plugin
 	, draft_plugin
diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs
index ea23ab982d..f64dd674cc 100644
--- a/utils/hpc/HpcCombine.hs
+++ b/utils/hpc/HpcCombine.hs
@@ -3,7 +3,7 @@
 -- 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
@@ -16,64 +16,115 @@ import qualified HpcMap as Map
 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
@@ -86,12 +137,12 @@ mergeTix f
 	       	     -> 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 
diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs
index 30d46799f1..761163f2dc 100644
--- a/utils/hpc/HpcFlags.hs
+++ b/utils/hpc/HpcFlags.hs
@@ -25,8 +25,9 @@ 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
@@ -45,9 +46,11 @@ 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.
 
@@ -98,16 +101,27 @@ 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 }
+
 
-postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked"
-							      $ \ f -> f { funTotals = True }  
 -------------------------------------------------------------------------------
 
 readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
@@ -121,6 +135,7 @@ command_usage plugin =
   putStrLn $
 				       "Usage: hpc " ++ (name plugin) ++ " " ++ 
 				        (usage plugin) ++
+				        "\n" ++ summary plugin ++ "\n" ++
 				        if null (options plugin [])
 				        then ""
   	                                else usageInfo "\n\nOptions:\n" (options plugin [])
@@ -178,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)
 
-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]
+	   ]
+