X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhpc%2FHpcMarkup.hs;h=3be17c8da69e3cf50e3ca25c07779a72bcc902a4;hb=f9c199a1a2865bdb9e8fb318a48058d7e4bfaf64;hp=53eaf323e8e07340c90823d5cbe4affbc88acd93;hpb=11d36d9f0256a3a3ef2934a776924f7c90afb6de;p=ghc-hetmet.git

diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs
index 53eaf32..3be17c8 100644
--- a/utils/hpc/HpcMarkup.hs
+++ b/utils/hpc/HpcMarkup.hs
@@ -10,20 +10,25 @@ import Trace.Hpc.Tix
 import Trace.Hpc.Util
 
 import HpcFlags
+import HpcUtils
 
 import System.Environment
+import System.Directory
 import Data.List
 import Data.Maybe(fromJust)
 import Data.Array
-import qualified Data.Set as Set
+import qualified HpcSet as Set
 
 ------------------------------------------------------------------------------
 
-markup_options = 
-  [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
-  , altHighlightOpt
-  , destDirOpt
-  ]
+markup_options 
+        = excludeOpt
+        . includeOpt
+        . srcDirOpt
+        . hpcDirOpt
+        . funTotalsOpt
+        . altHighlightOpt
+        . destDirOpt
        	 
 markup_plugin = Plugin { name = "markup"
 	      	       , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" 
@@ -43,20 +48,23 @@ markup_main flags (prog:modNames) = do
   	      	     	 	   `Set.union` 
 				includeMods flags }
   let Flags
-       { hpcDirs = hpcDirs
-       , hsDirs = theHsPath
-       , funTotals = theFunTotals
+       { funTotals = theFunTotals
        , altHighlight = invertOutput
        , destDir = dest_dir
        }  = hpcflags1
 
   mtix <- readTix (getTixFileName prog)
   Tix tixs <- case mtix of
-    Nothing -> error $ "unable to find tix file for: " ++ prog
+    Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog
     Just a -> return a
 
+#if __GLASGOW_HASKELL__ >= 604 
+  -- create the dest_dir if needed
+  createDirectoryIfMissing True dest_dir
+#endif
+
   mods <-
-     sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput
+     sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
 	      | tix <- tixs
 	      , allowModule hpcflags1 (tixModuleName tix)
    	      ]
@@ -68,6 +76,9 @@ markup_main flags (prog:modNames) = do
 
   let writeSummary name cmp = do
         let mods' = sortBy cmp mods
+
+
+
    
         putStrLn $ "Writing: " ++ (name ++ ".html")
         writeFile (dest_dir ++ "/" ++ name ++ ".html") $ 
@@ -75,6 +86,7 @@ markup_main flags (prog:modNames) = do
 	    "<style type=\"text/css\">" ++
 	    "table.bar { background-color: #f25913; }\n" ++
 	    "td.bar { background-color: #60de51;  }\n" ++
+	    "td.invbar { background-color: #f25913;  }\n" ++
 	    "table.dashboard { border-collapse: collapse  ; border: solid 1px black }\n" ++
 	    ".dashboard td { border: solid 1px black }\n" ++
 	    ".dashboard th { border: solid 1px black }\n" ++
@@ -119,20 +131,20 @@ markup_main flags (prog:modNames) = do
 		(percent (expTicked s1) (expTotal s1))
 
 
-markup_main flags [] = error $ "no .tix file or executable name specified" 
+markup_main flags [] = hpcError markup_plugin $ "no .tix file or executable name specified" 
 
 genHtmlFromMod
   :: String
-  -> [FilePath]
+  -> Flags
   -> TixModule
   -> Bool
-  -> [String]
   -> Bool
   -> IO (String, [Char], ModuleSummary)
-genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
+genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
+  let theHsPath = srcDirs flags
   let modName0 = tixModuleName tix 
 
-  (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0
+  (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags (Right tix)
 
   let arr_tix :: Array Int Integer
       arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
@@ -195,7 +207,7 @@ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
                   }
 
   -- add prefix to modName argument
-  content <- readFileFromPath origFile theHsPath
+  content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath
 
   let content' = markup tabStop info content
   let show' = reverse . take 5 . (++ "       ") . reverse . show
@@ -411,14 +423,16 @@ showSummary ticked total =
 		"<td width=100>" ++ 
 		    (case percent ticked total of
 		       Nothing -> "&nbsp;"
-		       Just w -> "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
-		       		     "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
-		              "<tr><td height=12 class=\"bar\"></td></tr>" ++
-			      "</table></td></tr></table>")
-			      ++ "</td>"
+		       Just w -> bar w "bar"
+		     )  ++ "</td>"
      where
         showP Nothing = "-&nbsp;"
         showP (Just x) = show x ++ "%"
+        bar 0 inner = bar 100 "invbar"
+        bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
+			 "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
+		              "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
+			      "</table></td></tr></table>"
 
 percent :: (Integral a) => a -> a -> Maybe a
 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
@@ -437,16 +451,3 @@ red    = "#f20913"
 green  = "#60de51"
 yellow = "yellow"
 
-------------------------------------------------------------------------------
-
-readFileFromPath :: String -> [String] -> IO String
-readFileFromPath filename@('/':_) _ = readFile filename
-readFileFromPath filename path0 = readTheFile path0
-  where
-	readTheFile :: [String] -> IO String
-	readTheFile [] = error $ "could not find " ++ show filename 
-			         ++ " in path " ++ show path0
-	readTheFile (dir:dirs) = 
-		catch (do str <- readFile (dir ++ "/" ++ filename) 
-			  return str) 
-		      (\ _ -> readTheFile dirs)