1 ---------------------------------------------------------
2 -- The main program for the hpc-markup tool, part of HPC.
3 -- Andy Gill and Colin Runciman, June 2006
4 ---------------------------------------------------------
6 module HpcMarkup (markup_plugin) where
14 import System.Environment
15 import System.Directory
17 import Data.Maybe(fromJust)
19 import qualified HpcSet as Set
21 ------------------------------------------------------------------------------
24 [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
26 #if __GLASGOW_HASKELL__ >= 604
31 markup_plugin = Plugin { name = "markup"
32 , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
33 , options = markup_options
34 , summary = "Markup Haskell source with program coverage"
35 , implementation = markup_main
36 , init_flags = default_flags
37 , final_flags = default_final_flags
40 ------------------------------------------------------------------------------
42 markup_main :: Flags -> [String] -> IO ()
43 markup_main flags (prog:modNames) = do
45 { includeMods = Set.fromList modNames
51 , funTotals = theFunTotals
52 , altHighlight = invertOutput
56 mtix <- readTix (getTixFileName prog)
57 Tix tixs <- case mtix of
58 Nothing -> error $ "unable to find tix file for: " ++ prog
61 #if __GLASGOW_HASKELL__ >= 604
62 -- create the dest_dir if needed
63 createDirectoryIfMissing True dest_dir
67 sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput
69 , allowModule hpcflags1 (tixModuleName tix)
72 let index_name = "hpc_index"
73 index_fun = "hpc_index_fun"
74 index_alt = "hpc_index_alt"
75 index_exp = "hpc_index_exp"
77 let writeSummary name cmp = do
78 let mods' = sortBy cmp mods
83 putStrLn $ "Writing: " ++ (name ++ ".html")
84 writeFile (dest_dir ++ "/" ++ name ++ ".html") $
86 "<style type=\"text/css\">" ++
87 "table.bar { background-color: #f25913; }\n" ++
88 "td.bar { background-color: #60de51; }\n" ++
89 "td.invbar { background-color: #f25913; }\n" ++
90 "table.dashboard { border-collapse: collapse ; border: solid 1px black }\n" ++
91 ".dashboard td { border: solid 1px black }\n" ++
92 ".dashboard th { border: solid 1px black }\n" ++
94 "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
96 "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
97 "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
98 "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
99 "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
103 "<th colspan=2>covered / total</th>" ++
105 "<th colspan=2>covered / total</th>" ++
107 "<th colspan=2>covered / total</th>" ++
109 concat [ showModuleSummary (modName,fileName,summary)
110 | (modName,fileName,summary) <- mods'
113 showTotalSummary (foldr1 combineSummary
115 | (_,_,summary) <- mods'
117 ++ "</table></html>\n"
119 writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2
121 writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
122 compare (percent (topFunTicked s2) (topFunTotal s2))
123 (percent (topFunTicked s1) (topFunTotal s1))
125 writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
126 compare (percent (altTicked s2) (altTotal s2))
127 (percent (altTicked s1) (altTotal s1))
129 writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
130 compare (percent (expTicked s2) (expTotal s2))
131 (percent (expTicked s1) (expTotal s1))
134 markup_main flags [] = error $ "no .tix file or executable name specified"
143 -> IO (String, [Char], ModuleSummary)
144 genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
145 let modName0 = tixModuleName tix
147 (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0
149 let arr_tix :: Array Int Integer
150 arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
153 let tickedWith :: Int -> Integer
154 tickedWith n = arr_tix ! n
156 isTicked n = tickedWith n /= 0
158 let info = [ (pos,theMarkup)
159 | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
160 , let binBox = case (isTicked gid,isTicked (gid+1)) of
162 (True,False) -> [TickedOnlyTrue]
163 (False,True) -> [TickedOnlyFalse]
165 , let tickBox = if isTicked gid
168 , theMarkup <- case boxLabel of
171 -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
172 LocalBox {} -> tickBox
173 BinBox _ True -> binBox
178 let summary = foldr (.) id
182 -> st { expTicked = ticked (expTicked st)
183 , expTotal = succ (expTotal st)
186 -> st { expTicked = ticked (expTicked st)
187 , expTotal = succ (expTotal st)
188 , altTicked = ticked (altTicked st)
189 , altTotal = succ (altTotal st)
192 st { topFunTicked = ticked (topFunTicked st)
193 , topFunTotal = succ (topFunTotal st)
196 | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
197 , let ticked = if isTicked gid
209 -- add prefix to modName argument
210 content <- readFileFromPath origFile theHsPath
212 let content' = markup tabStop info content
213 let show' = reverse . take 5 . (++ " ") . reverse . show
214 let addLine n xs = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs
215 let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
216 let fileName = modName0 ++ ".hs.html"
217 putStrLn $ "Writing: " ++ fileName
218 writeFile (dest_dir ++ "/" ++ fileName) $
219 unlines [ "<html><style type=\"text/css\">",
220 "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
222 then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
223 else "span.nottickedoff { background: " ++ yellow ++ "}",
225 then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
226 else "span.istickedoff { background: white }",
227 "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
228 "span.tickonlytrue { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
229 "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
231 then "span.decl { font-weight: bold; background: #d0c0ff }"
232 else "span.decl { font-weight: bold }",
233 "span.spaces { background: white }",
235 "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n";
237 summary `seq` return (modName0,fileName,summary)
239 data Loc = Loc !Int !Int
240 deriving (Eq,Ord,Show)
248 Bool -- display entry totals
252 markup :: Int -- ^tabStop
253 -> [(HpcPos,Markup)] -- random list of tick location pairs
254 -> String -- text to mark up
256 markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
258 tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
260 , let (ln1,c1,ln2,c2) = fromHpcPos pos
262 sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
263 (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs
265 addMarkup :: Int -- tabStop
266 -> String -- text to mark up
267 -> Loc -- current location
268 -> [(Loc,Markup)] -- stack of open ticks, with closing location
269 -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
272 -- check the pre-condition.
273 --addMarkup tabStop cs loc os ticks
274 -- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os
276 --addMarkup tabStop cs loc os@(_:_) ticks
277 -- | trace (show (loc,os,take 10 ticks)) False = undefined
279 -- close all open ticks, if we have reached the end
280 addMarkup _ [] _loc os [] =
281 concatMap (const closeTick) os
282 addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
283 closeTick ++ addMarkup tabStop cs loc os ticks
285 --addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
286 -- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks
288 addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
291 | not (allowNesting tik0 tik')
292 -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
293 _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
296 addTo (t,tik) [] = [(t,tik)]
297 addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs
298 | t > t' = (t',tik):(t',tik'):xs
300 addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
301 -- throw away this tick, because it is from a previous place ??
302 addMarkup tabStop0 cs loc os ticks
304 addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
305 | ln == ln2 && col < col2
306 = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
307 addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
308 if c0=='\n' && os/=[] then
309 concatMap (const closeTick) (downToTopLevel os) ++
310 c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
311 concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
312 addMarkup tabStop0 cs' loc' os ticks
313 else if c0=='\t' then
314 expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
316 escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
318 (w,cs') = span (`elem` " \t") cs
319 loc' = foldl (flip incBy) loc (c0:w)
322 escape '"' = """
326 expand :: Int -> String -> String
328 expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
330 c' = tabStopAfter 8 c
331 expand c (' ':s) = ' ' : expand (c+1) s
332 expand _ _ = error "bad character in string for expansion"
334 incBy :: Char -> Loc -> Loc
335 incBy '\n' (Loc ln _c) = Loc (succ ln) 1
336 incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
337 incBy _ (Loc ln c) = Loc ln (succ c)
339 tabStopAfter :: Int -> Int -> Int
340 tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])
343 addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)
345 openTick :: Markup -> String
346 openTick NotTicked = "<span class=\"nottickedoff\">"
347 openTick IsTicked = "<span class=\"istickedoff\">"
348 openTick TickedOnlyTrue = "<span class=\"tickonlytrue\">"
349 openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
350 openTick (TopLevelDecl False _) = openTopDecl
351 openTick (TopLevelDecl True 0)
352 = "<span class=\"funcount\">-- never entered</span>" ++
354 openTick (TopLevelDecl True 1)
355 = "<span class=\"funcount\">-- entered once</span>" ++
357 openTick (TopLevelDecl True n0)
358 = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl
359 where showBigNum n | n <= 9999 = show n
360 | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
361 showBigNum' n | n <= 999 = show n
362 | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
363 showWith n = take 3 $ reverse $ ("000" ++) $ reverse $ show n
366 closeTick = "</span>"
368 openTopDecl :: String
369 openTopDecl = "<span class=\"decl\">"
371 downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
372 downToTopLevel ((_,TopLevelDecl {}):_) = []
373 downToTopLevel (o : os) = o : downToTopLevel os
374 downToTopLevel [] = []
377 -- build in logic for nesting bin boxes
379 allowNesting :: Markup -- innermost
380 -> Markup -- outermost
382 allowNesting n m | n == m = False -- no need to double nest
383 allowNesting IsTicked TickedOnlyFalse = False
384 allowNesting IsTicked TickedOnlyTrue = False
385 allowNesting _ _ = True
387 ------------------------------------------------------------------------------
389 data ModuleSummary = ModuleSummary
392 , topFunTicked :: !Int
393 , topFunTotal :: !Int
400 showModuleSummary :: (String, String, ModuleSummary) -> String
401 showModuleSummary (modName,fileName,summary) =
403 "<td> <tt>module <a href=\"" ++ fileName ++ "\">"
404 ++ modName ++ "</a></tt></td>\n" ++
405 showSummary (topFunTicked summary) (topFunTotal summary) ++
406 showSummary (altTicked summary) (altTotal summary) ++
407 showSummary (expTicked summary) (expTotal summary) ++
410 showTotalSummary :: ModuleSummary -> String
411 showTotalSummary summary =
412 "<tr style=\"background: #e0e0e0\">\n" ++
413 "<th align=left> Program Coverage Total</tt></th>\n" ++
414 showSummary (topFunTicked summary) (topFunTotal summary) ++
415 showSummary (altTicked summary) (altTotal summary) ++
416 showSummary (expTicked summary) (expTotal summary) ++
419 showSummary :: (Integral t) => t -> t -> String
420 showSummary ticked total =
421 "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
422 "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
424 (case percent ticked total of
426 Just w -> bar w "bar"
429 showP Nothing = "- "
430 showP (Just x) = show x ++ "%"
431 bar 0 inner = bar 100 "invbar"
432 bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
433 "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
434 "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
435 "</table></td></tr></table>"
437 percent :: (Integral a) => a -> a -> Maybe a
438 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
441 combineSummary :: ModuleSummary -> ModuleSummary -> ModuleSummary
442 combineSummary (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
443 (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
444 = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
446 ------------------------------------------------------------------------------
447 -- global color pallete
449 red,green,yellow :: String
454 ------------------------------------------------------------------------------
456 readFileFromPath :: String -> [String] -> IO String
457 readFileFromPath filename@('/':_) _ = readFile filename
458 readFileFromPath filename path0 = readTheFile path0
460 readTheFile :: [String] -> IO String
461 readTheFile [] = error $ "could not find " ++ show filename
462 ++ " in path " ++ show path0
463 readTheFile (dir:dirs) =
464 catch (do str <- readFile (dir ++ "/" ++ filename)
466 (\ _ -> readTheFile dirs)