X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhpc%2FHpcOverlay.hs;h=a074d6c7faafd9d7e78ba5135d683bd717d4d91b;hb=9e5a454cd78650a0c9e2a859693ee1af056b3fb9;hp=0cf56e4ae35b21c184ee0f14e941a1f29c5329a4;hpb=c8742f253f0c0b38f977530eceaaecac55578b4b;p=ghc-hetmet.git

diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs
index 0cf56e4..a074d6c 100644
--- a/utils/hpc/HpcOverlay.hs
+++ b/utils/hpc/HpcOverlay.hs
@@ -6,14 +6,16 @@ import HpcUtils
 import Trace.Hpc.Tix
 import Trace.Hpc.Mix
 import Trace.Hpc.Util
-import HpcMap as Map
+import qualified Data.Map as Map
 import Data.Tree
 
+overlay_options :: FlagOptSeq
 overlay_options 
         = srcDirOpt
         . hpcDirOpt
         . outputOpt
 
+overlay_plugin :: Plugin
 overlay_plugin = Plugin { name = "overlay"
 	      	       , usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]" 
 		       , options = overlay_options 
@@ -23,19 +25,19 @@ overlay_plugin = Plugin { name = "overlay"
 		       , final_flags = default_final_flags
 		       }
 
-
-overlay_main flags [] = hpcError overlay_plugin $ "no overlay file specified" 
+overlay_main :: Flags -> [String] -> IO ()
+overlay_main _     [] = hpcError overlay_plugin $ "no overlay file specified" 
 overlay_main flags files = do
   specs <- mapM hpcParser files
-  let spec@(Spec globals modules) = concatSpec specs
+  let (Spec globals modules) = concatSpec specs
 
   let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]
 
   mod_info <-
-     sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left mod)
+     sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu)
 	           content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
-	           processModule mod content mix mod_spec globals
-              | (mod,mod_spec) <- Map.toList modules1
+	           processModule modu content mix mod_spec globals
+              | (modu, mod_spec) <- Map.toList modules1
               ]
 
 
@@ -52,7 +54,7 @@ processModule :: String		-- ^ module name
               -> [Tick] 	-- ^ local ticks
               -> [ExprTick]	-- ^ global ticks
               -> IO TixModule 
-processModule modName modContents (Mix filepath timestamp hash tabstop entries) locals globals = do
+processModule modName modContents (Mix _ _ hash _ entries) locals globals = do
 
    let hsMap :: Map.Map Int String
        hsMap = Map.fromList (zip [1..] $ lines modContents)
@@ -71,7 +73,7 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries)
 
    -- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick
    let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool
-       plzTick pos (ExpBox _) (TickExpression _ match q g)  =
+       plzTick pos (ExpBox _) (TickExpression _ match q _)  =
                      qualifier pos q
                   && case match of
 			Nothing -> True
@@ -81,7 +83,7 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries)
 
        plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool
        plzTopTick pos label  (ExprTick ignore)           = plzTick pos label ignore
-       plzTopTick pos _      (TickFunction fn q g)   =
+       plzTopTick pos _      (TickFunction fn q _)   =
                     qualifier pos q && pos `inside` fn
        plzTopTick pos label  (InsideFunction fn igs)   =
          pos `inside` fn && any (plzTopTick pos label) igs
@@ -95,11 +97,11 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries)
               ]
 
 
-   let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
+   -- let show' (srcspan,stuff) = show (srcspan,stuff,grabHpcPos hsMap span)
 
    let forest = createMixEntryDom
-              [ (span,ix)
-              | ((span,_),ix) <- zip entries [0..]
+              [ (srcspan,ix)
+              | ((srcspan,_),ix) <- zip entries [0..]
               ]
 
 
@@ -131,16 +133,17 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries)
    return $ TixModule modName hash (length tixs') tixs'
 
 qualifier :: HpcPos -> Maybe Qualifier -> Bool
-qualifier pos Nothing = True
+qualifier _   Nothing = True
 qualifier pos (Just (OnLine n)) = n == l1 && n == l2
-  where (l1,c1,l2,c2) = fromHpcPos pos
+  where (l1,_,l2,_) = fromHpcPos pos
 qualifier pos (Just (AtPosition l1' c1' l2' c2')) 
 	  = (l1', c1', l2', c2') == fromHpcPos pos
 
 concatSpec :: [Spec] -> Spec
-concatSpec = foldl1 $ 
-	       \ (Spec pre1 body1) (Spec pre2 body2) 
-		     -> Spec (pre1 ++ pre2) (body1 ++ body2)
+concatSpec = foldr 
+	       (\ (Spec pre1 body1) (Spec pre2 body2) 
+		     -> Spec (pre1 ++ pre2) (body1 ++ body2))
+		(Spec [] [])