X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=utils%2Fhpc%2FHpcMarkup.hs;h=df7e43b5eaa6f77e72ebee4c63268e690a17b0a4;hb=0f39a76981957c7120e42dda04c07f394692cfdb;hp=53eaf323e8e07340c90823d5cbe4affbc88acd93;hpb=11d36d9f0256a3a3ef2934a776924f7c90afb6de;p=ghc-hetmet.git diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index 53eaf32..df7e43b 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -10,21 +10,29 @@ 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 Data.Monoid +import Control.Monad +import qualified HpcSet as Set ------------------------------------------------------------------------------ -markup_options = - [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt - , altHighlightOpt - , destDirOpt - ] - +markup_options :: FlagOptSeq +markup_options + = excludeOpt + . includeOpt + . srcDirOpt + . hpcDirOpt + . funTotalsOpt + . altHighlightOpt + . destDirOpt + +markup_plugin :: Plugin markup_plugin = Plugin { name = "markup" , usage = "[OPTION] .. [ [ ..]]" , options = markup_options @@ -43,20 +51,18 @@ 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 mods <- - sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput + sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput | tix <- tixs , allowModule hpcflags1 (tixModuleName tix) ] @@ -66,15 +72,17 @@ 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: " ++ (name ++ ".html") - writeFile (dest_dir ++ "/" ++ name ++ ".html") $ + + putStrLn $ "Writing: " ++ (filename ++ ".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) @@ -282,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 ?? @@ -386,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 @@ -411,23 +413,52 @@ showSummary ticked total = "" ++ (case percent ticked total of Nothing -> " " - Just w -> "" ++ - "
" ++ - "" ++ - "
") - ++ "" + Just w -> bar w "bar" + ) ++ "" where showP Nothing = "- " showP (Just x) = show x ++ "%" + bar 0 _ = bar 100 "invbar" + bar w inner = "" ++ + "
" ++ + "" ++ + "
" 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 @@ -437,16 +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 [] = error $ "could not find " ++ show filename - ++ " in path " ++ show path0 - readTheFile (dir:dirs) = - catch (do str <- readFile (dir ++ "/" ++ filename) - return str) - (\ _ -> readTheFile dirs)