X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhpc%2FHpcMarkup.hs;h=e618b25ba8989acc6998e6b172c72f5396478f1e;hb=2fa48f4ea462a6e7f0bb22a8c292ee4efcec81e0;hp=a46fd799eb1c0f9d3e6fb55eda987b42e30bfa8b;hpb=78a1b71ccc5a99711f434dae99dd892c920324fe;p=ghc-hetmet.git diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index a46fd79..e618b25 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -10,22 +10,28 @@ 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 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 @@ -44,23 +50,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 - -- create the dest_dir if needed - createDirectoryIfMissing True dest_dir - mods <- - sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput + sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput | tix <- tixs , allowModule hpcflags1 (tixModuleName tix) ] @@ -70,14 +71,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) @@ -290,8 +283,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 ?? @@ -394,22 +387,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 @@ -424,7 +417,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 = "" ++ "
" ++ "" ++ @@ -434,10 +427,36 @@ 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 + createDirectoryIfMissing True dest_dir +#endif + + writeFile filename text ------------------------------------------------------------------------------ -- global color pallete @@ -447,16 +466,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)