X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhpc%2FHpcMarkup.hs;h=df7e43b5eaa6f77e72ebee4c63268e690a17b0a4;hb=831a35dd00faff195cf938659c2dd736192b865f;hp=4b3b976f5aee774c375b9529e05a91350d5a4331;hpb=4799dfb37be922c17451f8e0f7c8d765a7a7eaab;p=ghc-hetmet.git diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index 4b3b976..df7e43b 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -10,16 +10,19 @@ 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 Control.Monad import qualified HpcSet as Set ------------------------------------------------------------------------------ +markup_options :: FlagOptSeq markup_options = excludeOpt . includeOpt @@ -28,7 +31,8 @@ markup_options . funTotalsOpt . altHighlightOpt . destDirOpt - + +markup_plugin :: Plugin markup_plugin = Plugin { name = "markup" , usage = "[OPTION] .. [ [ ..]]" , options = markup_options @@ -57,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 @@ -73,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) @@ -293,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 ?? @@ -397,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 @@ -427,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 = "" ++ "
" ++ "" ++ @@ -437,10 +428,37 @@ 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) + + +------------------------------------------------------------------------------ + +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 @@ -450,17 +468,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 [] = hpcError markup_plugin - $ "could not find " ++ show filename - ++ " in path " ++ show path0 - readTheFile (dir:dirs) = - catch (do str <- readFile (dir ++ "/" ++ filename) - return str) - (\ _ -> readTheFile dirs)