Extra info in genprimopcode --make-ext-core-source

[ghc-hetmet.git] / utils / hpc / HpcMarkup.hs

diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs
index d4f4ee6..a40c297 100644 (file)
--- a/utils/hpc/HpcMarkup.hs
+++ b/utils/hpc/HpcMarkup.hs
@@ -10,22 +10,26 @@ 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 Data.Monoid
 import qualified HpcSet as Set
 
 ------------------------------------------------------------------------------
 
-markup_options = 
-  [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
-  , altHighlightOpt
-#if __GLASGOW_HASKELL__ >= 604 
-  , destDirOpt
-#endif
-  ]
+markup_options 
+        = excludeOpt
+        . includeOpt
+        . srcDirOpt
+        . hpcDirOpt
+        . funTotalsOpt
+        . altHighlightOpt
+        . destDirOpt
                 
 markup_plugin = Plugin { name = "markup"
                       , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" 
@@ -45,16 +49,14 @@ 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 
@@ -63,7 +65,7 @@ markup_main flags (prog:modNames) = do
 #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)
              ]
@@ -109,7 +111,7 @@ markup_main flags (prog:modNames) = do
                   | (modName,fileName,summary) <- mods'
                   ] ++
            "<tr></tr>" ++
-           showTotalSummary (foldr1 combineSummary 
+           showTotalSummary (mconcat
                                 [ summary 
                                 | (_,_,summary) <- mods'
                                 ])
@@ -130,20 +132,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)
@@ -196,17 +198,10 @@ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
              , let ticked = if isTicked gid
                            then succ
                            else id
-             ] $ ModuleSummary 
-                 { expTicked = 0
-                 , expTotal  = 0
-                  , topFunTicked = 0
-                  , topFunTotal  = 0
-                  , altTicked = 0
-                  , altTotal  = 0
-                  }
+             ] $ mempty
 
   -- 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
@@ -437,10 +432,19 @@ percent :: (Integral a) => a -> a -> Maybe a
 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
 
 
-combineSummary :: ModuleSummary -> ModuleSummary -> ModuleSummary
-combineSummary (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
-              (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
-  = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
+instance Monoid ModuleSummary where
+  mempty = ModuleSummary
+                 { expTicked = 0
+                 , expTotal  = 0
+                  , topFunTicked = 0
+                  , topFunTotal  = 0
+                  , altTicked = 0
+                  , altTotal  = 0
+                  }
+  mappend (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
+         (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
+     = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
+
 
 ------------------------------------------------------------------------------
 -- global color pallete
@@ -450,16 +454,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)