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
. funTotalsOpt
. altHighlightOpt
. destDirOpt
-
+
+markup_plugin :: Plugin
markup_plugin = Plugin { name = "markup"
, usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
, options = markup_options
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
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") $
"<html>" ++
"<style type=\"text/css\">" ++
"table.bar { background-color: #f25913; }\n" ++
"<th>%</th>" ++
"<th colspan=2>covered / total</th>" ++
"</tr>" ++
- concat [ showModuleSummary (modName,fileName,summary)
- | (modName,fileName,summary) <- mods'
+ concat [ showModuleSummary (modName,fileName,modSummary)
+ | (modName,fileName,modSummary) <- mods'
] ++
"<tr></tr>" ++
- showTotalSummary (foldr1 combineSummary
- [ summary
- | (_,_,summary) <- mods'
+ showTotalSummary (mconcat
+ [ modSummary
+ | (_,_,modSummary) <- mods'
])
++ "</table></html>\n"
(percent (expTicked s1) (expTotal s1))
-markup_main flags [] = hpcError markup_plugin $ "no .tix file or executable name specified"
+markup_main _ []
+ = hpcError markup_plugin $ "no .tix file or executable name specified"
genHtmlFromMod
:: String
let theHsPath = srcDirs flags
let modName0 = tixModuleName tix
- (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags modName0
+ (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix)
let arr_tix :: Array Int Integer
arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
]
- let summary = foldr (.) id
+ let modSummary = foldr (.) id
[ \ st ->
case boxLabel of
ExpBox False
, 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
let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
let fileName = modName0 ++ ".hs.html"
putStrLn $ "Writing: " ++ fileName
- writeFile (dest_dir ++ "/" ++ fileName) $
+ writeFileUsing (dest_dir ++ "/" ++ fileName) $
unlines [ "<html><style type=\"text/css\">",
"span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
if invertOutput
"</style>",
"<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n";
- summary `seq` return (modName0,fileName,summary)
+ modSummary `seq` return (modName0,fileName,modSummary)
data Loc = Loc !Int !Int
deriving (Eq,Ord,Show)
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 ??
showModuleSummary :: (String, String, ModuleSummary) -> String
-showModuleSummary (modName,fileName,summary) =
+showModuleSummary (modName,fileName,modSummary) =
"<tr>\n" ++
"<td> <tt>module <a href=\"" ++ fileName ++ "\">"
++ modName ++ "</a></tt></td>\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) ++
"</tr>\n"
showTotalSummary :: ModuleSummary -> String
-showTotalSummary summary =
+showTotalSummary modSummary =
"<tr style=\"background: #e0e0e0\">\n" ++
"<th align=left> Program Coverage Total</tt></th>\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) ++
"</tr>\n"
showSummary :: (Integral t) => t -> t -> String
where
showP Nothing = "- "
showP (Just x) = show x ++ "%"
- bar 0 inner = bar 100 "invbar"
+ bar 0 _ = bar 100 "invbar"
bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
"<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
"<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
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
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)
projects / ghc-hetmet.git / blobdiff