X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhpc%2FHpcMarkup.hs;h=df7e43b5eaa6f77e72ebee4c63268e690a17b0a4;hb=8aaa9ef471cadbc79fca58b234b198065f650dcf;hp=a40c297d4f7185bd126f9ded8cd5af51765300ed;hpb=8b6f1dbd2d68af0652aebb8bc3253c64086305f4;p=ghc-hetmet.git diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index a40c297..df7e43b 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -12,16 +12,17 @@ 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 Control.Monad import qualified HpcSet as Set ------------------------------------------------------------------------------ +markup_options :: FlagOptSeq markup_options = excludeOpt . includeOpt @@ -30,7 +31,8 @@ markup_options . funTotalsOpt . altHighlightOpt . destDirOpt - + +markup_plugin :: Plugin markup_plugin = Plugin { name = "markup" , usage = "[OPTION] .. [ [ ..]]" , options = markup_options @@ -59,11 +61,6 @@ markup_main flags (prog:modNames) = do 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 hpcflags1 tix theFunTotals invertOutput | tix <- tixs @@ -75,14 +72,12 @@ markup_main flags (prog:modNames) = do index_alt = "hpc_index_alt" index_exp = "hpc_index_exp" - let writeSummary name cmp = do + let writeSummary filename cmp = do let mods' = sortBy cmp mods + putStrLn $ "Writing: " ++ (filename ++ ".html") - - - putStrLn $ "Writing: " ++ (name ++ ".html") - writeFile (dest_dir ++ "/" ++ name ++ ".html") $ + writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $ "" ++ "", "
"] ++ addLines content' ++ "\n
\n\n"; - summary `seq` return (modName0,fileName,summary) + modSummary `seq` return (modName0,fileName,modSummary) data Loc = Loc !Int !Int deriving (Eq,Ord,Show) @@ -288,8 +284,8 @@ addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 = where addTo (t,tik) [] = [(t,tik)] - addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs - | t > t' = (t',tik):(t',tik'):xs + addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs + | otherwise = (t',tik):(t',tik'):xs addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 = -- throw away this tick, because it is from a previous place ?? @@ -392,22 +388,22 @@ data ModuleSummary = ModuleSummary showModuleSummary :: (String, String, ModuleSummary) -> String -showModuleSummary (modName,fileName,summary) = +showModuleSummary (modName,fileName,modSummary) = "\n" ++ "  module " ++ modName ++ "\n" ++ - showSummary (topFunTicked summary) (topFunTotal summary) ++ - showSummary (altTicked summary) (altTotal summary) ++ - showSummary (expTicked summary) (expTotal summary) ++ + showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ + showSummary (altTicked modSummary) (altTotal modSummary) ++ + showSummary (expTicked modSummary) (expTotal modSummary) ++ "\n" showTotalSummary :: ModuleSummary -> String -showTotalSummary summary = +showTotalSummary modSummary = "\n" ++ "  Program Coverage Total\n" ++ - showSummary (topFunTicked summary) (topFunTotal summary) ++ - showSummary (altTicked summary) (altTotal summary) ++ - showSummary (expTicked summary) (expTotal summary) ++ + showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ + showSummary (altTicked modSummary) (altTotal modSummary) ++ + showSummary (expTicked modSummary) (expTotal modSummary) ++ "\n" showSummary :: (Integral t) => t -> t -> String @@ -422,7 +418,7 @@ showSummary ticked total = where showP Nothing = "- " showP (Just x) = show x ++ "%" - bar 0 inner = bar 100 "invbar" + bar 0 _ = bar 100 "invbar" bar w inner = "" ++ "
" ++ "" ++ @@ -447,6 +443,24 @@ instance Monoid ModuleSummary where ------------------------------------------------------------------------------ + +writeFileUsing :: String -> String -> IO () +writeFileUsing filename text = do + let dest_dir = reverse . dropWhile (\ x -> x /= '/') . reverse $ filename + +-- We need to check for the dest_dir each time, because we use sub-dirs for +-- packages, and a single .tix file might contain information about +-- many package. + +#if __GLASGOW_HASKELL__ >= 604 + -- create the dest_dir if needed + when (not (null dest_dir)) $ + createDirectoryIfMissing True dest_dir +#endif + + writeFile filename text + +------------------------------------------------------------------------------ -- global color pallete red,green,yellow :: String