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

diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs
index 68bd861..30cc401 100644
--- a/utils/hpc/HpcFlags.hs
+++ b/utils/hpc/HpcFlags.hs
@@ -3,7 +3,6 @@
 module HpcFlags where
 
 import System.Console.GetOpt
-import Data.Maybe ( fromMaybe )
 import qualified HpcSet as Set
 import Data.Char
 import Trace.Hpc.Tix
@@ -25,10 +24,12 @@ 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
 default_flags = Flags
   { outputFile		= "-"
   , includeMods         = Set.empty
@@ -45,12 +46,15 @@ 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
 default_final_flags flags = flags 
   { srcDirs = if null (srcDirs flags)
     	      then ["."]
@@ -68,6 +72,10 @@ anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
 infoArg :: String -> FlagOptSeq
 infoArg info = (:) $ Option [] [] (NoArg $ id) info
 
+excludeOpt, includeOpt, hpcDirOpt, srcDirOpt, destDirOpt, outputOpt,
+    perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
+    altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
+    mapFunOptInfo, unionModuleOpt :: FlagOptSeq
 excludeOpt      = anArg "exclude"    "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"  
                 $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
 
@@ -98,28 +106,42 @@ 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 mod = readMix [ dir ++  "/" ++ hpcDir flags
-                                     | dir <- srcDirs flags 
-                                     ] mod
+readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
+readMixWithFlags flags modu = readMix [ dir ++  "/" ++ hpcDir flags
+                                      | dir <- srcDirs flags 
+                                      ] modu
 
 -------------------------------------------------------------------------------
 
+command_usage :: Plugin -> IO ()
 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 +199,44 @@ 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  _ = 0
+thePostFun ZERO _ = 0
+
+postFuns :: [(String, PostFun)]
+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 :: [(String, MergeFun)]
+mergeFuns = [ (show pos,pos) 
+	     | pos <- [INTERSECTION,UNION]
+	   ]
+