X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhpc%2FHpcFlags.hs;h=b4453670236562bfb4ee34474fd5967985b4a748;hb=10704b34c1928dde3d0ef33fe37c3eb7b948975f;hp=68bd86135349d3b9a1f6418a230c8e4f009787bc;hpb=4799dfb37be922c17451f8e0f7c8d765a7a7eaab;p=ghc-hetmet.git

diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs
index 68bd861..b445367 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,18 +101,30 @@ 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
 readMixWithFlags flags mod = readMix [ dir ++  "/" ++ hpcDir flags
                                      | dir <- srcDirs flags 
                                      ] mod
@@ -120,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 [])
@@ -177,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 <- [ID .. 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]
+	   ]
+