fb68eacef7624e1e4609de1fd2cea08041915601
[ghc.git] / utils / hpc / HpcMarkup.hs
1 ---------------------------------------------------------
2 -- The main program for the hpc-markup tool, part of HPC.
3 -- Andy Gill and Colin Runciman, June 2006
4 ---------------------------------------------------------
5
6 module HpcMarkup (markup_plugin) where
7
8 import Trace.Hpc.Mix
9 import Trace.Hpc.Tix
10 import Trace.Hpc.Util
11
12 import HpcFlags
13 import HpcUtils
14
15 import System.Directory
16 import System.FilePath
17 import System.IO (localeEncoding)
18 import Data.List
19 import Data.Maybe(fromJust)
20 import Data.Array
21 import Control.Monad
22 import qualified Data.Set as Set
23
24 ------------------------------------------------------------------------------
25
26 markup_options :: FlagOptSeq
27 markup_options
28 = excludeOpt
29 . includeOpt
30 . srcDirOpt
31 . hpcDirOpt
32 . resetHpcDirsOpt
33 . funTotalsOpt
34 . altHighlightOpt
35 . destDirOpt
36 . verbosityOpt
37
38 markup_plugin :: Plugin
39 markup_plugin = Plugin { name = "markup"
40 , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
41 , options = markup_options
42 , summary = "Markup Haskell source with program coverage"
43 , implementation = markup_main
44 , init_flags = default_flags
45 , final_flags = default_final_flags
46 }
47
48 ------------------------------------------------------------------------------
49
50 markup_main :: Flags -> [String] -> IO ()
51 markup_main flags (prog:modNames) = do
52 let hpcflags1 = flags
53 { includeMods = Set.fromList modNames
54 `Set.union`
55 includeMods flags }
56 let Flags
57 { funTotals = theFunTotals
58 , altHighlight = invertOutput
59 , destDir = dest_dir
60 } = hpcflags1
61
62 mtix <- readTix (getTixFileName prog)
63 Tix tixs <- case mtix of
64 Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog
65 Just a -> return a
66
67 mods <-
68 sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
69 | tix <- tixs
70 , allowModule hpcflags1 (tixModuleName tix)
71 ]
72
73 let index_name = "hpc_index"
74 index_fun = "hpc_index_fun"
75 index_alt = "hpc_index_alt"
76 index_exp = "hpc_index_exp"
77
78 let writeSummary filename cmp = do
79 let mods' = sortBy cmp mods
80
81 unless (verbosity flags < Normal) $
82 putStrLn $ "Writing: " ++ (filename <.> "html")
83
84 writeFileUsing (dest_dir </> filename <.> "html") $
85 "<html>" ++
86 "<head>" ++
87 charEncodingTag ++
88 "<style type=\"text/css\">" ++
89 "table.bar { background-color: #f25913; }\n" ++
90 "td.bar { background-color: #60de51; }\n" ++
91 "td.invbar { background-color: #f25913; }\n" ++
92 "table.dashboard { border-collapse: collapse ; border: solid 1px black }\n" ++
93 ".dashboard td { border: solid 1px black }\n" ++
94 ".dashboard th { border: solid 1px black }\n" ++
95 "</style>\n" ++
96 "</head>" ++
97 "<body>" ++
98 "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
99 "<tr>" ++
100 "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
101 "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
102 "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
103 "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
104 "</tr>" ++
105 "<tr>" ++
106 "<th>%</th>" ++
107 "<th colspan=2>covered / total</th>" ++
108 "<th>%</th>" ++
109 "<th colspan=2>covered / total</th>" ++
110 "<th>%</th>" ++
111 "<th colspan=2>covered / total</th>" ++
112 "</tr>" ++
113 concat [ showModuleSummary (modName,fileName,modSummary)
114 | (modName,fileName,modSummary) <- mods'
115 ] ++
116 "<tr></tr>" ++
117 showTotalSummary (mconcat
118 [ modSummary
119 | (_,_,modSummary) <- mods'
120 ])
121 ++ "</table></body></html>\n"
122
123 writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2
124
125 writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
126 compare (percent (topFunTicked s2) (topFunTotal s2))
127 (percent (topFunTicked s1) (topFunTotal s1))
128
129 writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
130 compare (percent (altTicked s2) (altTotal s2))
131 (percent (altTicked s1) (altTotal s1))
132
133 writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
134 compare (percent (expTicked s2) (expTotal s2))
135 (percent (expTicked s1) (expTotal s1))
136
137
138 markup_main _ []
139 = hpcError markup_plugin $ "no .tix file or executable name specified"
140
141 charEncodingTag :: String
142 charEncodingTag =
143 "<meta http-equiv=\"Content-Type\" " ++
144 "content=\"text/html; " ++ "charset=" ++ show localeEncoding ++ "\">"
145
146 -- Add characters to the left of a string until it is at least as
147 -- large as requested.
148 padLeft :: Int -> Char -> String -> String
149 padLeft n c str = go n str
150 where
151 -- If the string is already long enough, stop traversing it.
152 go 0 _ = str
153 go k [] = replicate k c ++ str
154 go k (_:xs) = go (k-1) xs
155
156 genHtmlFromMod
157 :: String
158 -> Flags
159 -> TixModule
160 -> Bool
161 -> Bool
162 -> IO (String, [Char], ModuleSummary)
163 genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
164 let theHsPath = srcDirs flags
165 let modName0 = tixModuleName tix
166
167 (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix)
168
169 let arr_tix :: Array Int Integer
170 arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
171 $ tixModuleTixs tix
172
173 let tickedWith :: Int -> Integer
174 tickedWith n = arr_tix ! n
175
176 isTicked n = tickedWith n /= 0
177
178 let info = [ (pos,theMarkup)
179 | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
180 , let binBox = case (isTicked gid,isTicked (gid+1)) of
181 (False,False) -> []
182 (True,False) -> [TickedOnlyTrue]
183 (False,True) -> [TickedOnlyFalse]
184 (True,True) -> []
185 , let tickBox = if isTicked gid
186 then [IsTicked]
187 else [NotTicked]
188 , theMarkup <- case boxLabel of
189 ExpBox {} -> tickBox
190 TopLevelBox {}
191 -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
192 LocalBox {} -> tickBox
193 BinBox _ True -> binBox
194 _ -> []
195 ]
196
197
198 let modSummary = foldr (.) id
199 [ \ st ->
200 case boxLabel of
201 ExpBox False
202 -> st { expTicked = ticked (expTicked st)
203 , expTotal = succ (expTotal st)
204 }
205 ExpBox True
206 -> st { expTicked = ticked (expTicked st)
207 , expTotal = succ (expTotal st)
208 , altTicked = ticked (altTicked st)
209 , altTotal = succ (altTotal st)
210 }
211 TopLevelBox _ ->
212 st { topFunTicked = ticked (topFunTicked st)
213 , topFunTotal = succ (topFunTotal st)
214 }
215 _ -> st
216 | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
217 , let ticked = if isTicked gid
218 then succ
219 else id
220 ] $ mempty
221
222 -- add prefix to modName argument
223 content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath
224
225 let content' = markup tabStop info content
226 let addLine n xs = "<span class=\"lineno\">" ++ padLeft 5 ' ' (show n) ++ " </span>" ++ xs
227 let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
228 let fileName = modName0 <.> "hs" <.> "html"
229 unless (verbosity flags < Normal) $
230 putStrLn $ "Writing: " ++ fileName
231 writeFileUsing (dest_dir </> fileName) $
232 unlines ["<html>",
233 "<head>",
234 charEncodingTag,
235 "<style type=\"text/css\">",
236 "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
237 if invertOutput
238 then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
239 else "span.nottickedoff { background: " ++ yellow ++ "}",
240 if invertOutput
241 then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
242 else "span.istickedoff { background: white }",
243 "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
244 "span.tickonlytrue { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
245 "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
246 if invertOutput
247 then "span.decl { font-weight: bold; background: #d0c0ff }"
248 else "span.decl { font-weight: bold }",
249 "span.spaces { background: white }",
250 "</style>",
251 "</head>",
252 "<body>",
253 "<pre>"] ++ addLines content' ++ "\n</pre>\n</body>\n</html>\n";
254
255
256 modSummary `seq` return (modName0,fileName,modSummary)
257
258 data Loc = Loc !Int !Int
259 deriving (Eq,Ord,Show)
260
261 data Markup
262 = NotTicked
263 | TickedOnlyTrue
264 | TickedOnlyFalse
265 | IsTicked
266 | TopLevelDecl
267 Bool -- display entry totals
268 Integer
269 deriving (Eq,Show)
270
271 markup :: Int -- ^tabStop
272 -> [(HpcPos,Markup)] -- random list of tick location pairs
273 -> String -- text to mark up
274 -> String
275 markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
276 where
277 tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
278 | (pos,mark) <- mix
279 , let (ln1,c1,ln2,c2) = fromHpcPos pos
280 ]
281 sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
282 (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs
283
284 addMarkup :: Int -- tabStop
285 -> String -- text to mark up
286 -> Loc -- current location
287 -> [(Loc,Markup)] -- stack of open ticks, with closing location
288 -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
289 -> String
290
291 -- check the pre-condition.
292 --addMarkup tabStop cs loc os ticks
293 -- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os
294
295 --addMarkup tabStop cs loc os@(_:_) ticks
296 -- | trace (show (loc,os,take 10 ticks)) False = undefined
297
298 -- close all open ticks, if we have reached the end
299 addMarkup _ [] _loc os [] =
300 concatMap (const closeTick) os
301 addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
302 closeTick ++ addMarkup tabStop cs loc os ticks
303
304 --addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
305 -- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks
306
307 addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
308 case os of
309 ((_,tik'):_)
310 | not (allowNesting tik0 tik')
311 -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
312 _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
313 where
314
315 addTo (t,tik) [] = [(t,tik)]
316 addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs
317 | otherwise = (t',tik):(t',tik'):xs
318
319 addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
320 -- throw away this tick, because it is from a previous place ??
321 addMarkup tabStop0 cs loc os ticks
322
323 addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
324 | ln == ln2 && col < col2
325 = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
326 addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
327 if c0=='\n' && os/=[] then
328 concatMap (const closeTick) (downToTopLevel os) ++
329 c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
330 concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
331 addMarkup tabStop0 cs' loc' os ticks
332 else if c0=='\t' then
333 expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
334 else
335 escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
336 where
337 (w,cs') = span (`elem` " \t") cs
338 loc' = foldl (flip incBy) loc (c0:w)
339 escape '>' = "&gt;"
340 escape '<' = "&lt;"
341 escape '"' = "&quot;"
342 escape '&' = "&amp;"
343 escape c = [c]
344
345 expand :: Int -> String -> String
346 expand _ "" = ""
347 expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
348 where
349 c' = tabStopAfter 8 c
350 expand c (' ':s) = ' ' : expand (c+1) s
351 expand _ _ = error "bad character in string for expansion"
352
353 incBy :: Char -> Loc -> Loc
354 incBy '\n' (Loc ln _c) = Loc (succ ln) 1
355 incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
356 incBy _ (Loc ln c) = Loc ln (succ c)
357
358 tabStopAfter :: Int -> Int -> Int
359 tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])
360
361
362 addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)
363
364 openTick :: Markup -> String
365 openTick NotTicked = "<span class=\"nottickedoff\">"
366 openTick IsTicked = "<span class=\"istickedoff\">"
367 openTick TickedOnlyTrue = "<span class=\"tickonlytrue\">"
368 openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
369 openTick (TopLevelDecl False _) = openTopDecl
370 openTick (TopLevelDecl True 0)
371 = "<span class=\"funcount\">-- never entered</span>" ++
372 openTopDecl
373 openTick (TopLevelDecl True 1)
374 = "<span class=\"funcount\">-- entered once</span>" ++
375 openTopDecl
376 openTick (TopLevelDecl True n0)
377 = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl
378 where showBigNum n | n <= 9999 = show n
379 | otherwise = case n `quotRem` 1000 of
380 (q, r) -> showBigNum' q ++ "," ++ showWith r
381 showBigNum' n | n <= 999 = show n
382 | otherwise = case n `quotRem` 1000 of
383 (q, r) -> showBigNum' q ++ "," ++ showWith r
384 showWith n = padLeft 3 '0' $ show n
385
386
387
388 closeTick :: String
389 closeTick = "</span>"
390
391 openTopDecl :: String
392 openTopDecl = "<span class=\"decl\">"
393
394 downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
395 downToTopLevel ((_,TopLevelDecl {}):_) = []
396 downToTopLevel (o : os) = o : downToTopLevel os
397 downToTopLevel [] = []
398
399
400 -- build in logic for nesting bin boxes
401
402 allowNesting :: Markup -- innermost
403 -> Markup -- outermost
404 -> Bool
405 allowNesting n m | n == m = False -- no need to double nest
406 allowNesting IsTicked TickedOnlyFalse = False
407 allowNesting IsTicked TickedOnlyTrue = False
408 allowNesting _ _ = True
409
410 ------------------------------------------------------------------------------
411
412 data ModuleSummary = ModuleSummary
413 { expTicked :: !Int
414 , expTotal :: !Int
415 , topFunTicked :: !Int
416 , topFunTotal :: !Int
417 , altTicked :: !Int
418 , altTotal :: !Int
419 }
420 deriving (Show)
421
422
423 showModuleSummary :: (String, String, ModuleSummary) -> String
424 showModuleSummary (modName,fileName,modSummary) =
425 "<tr>\n" ++
426 "<td>&nbsp;&nbsp;<tt>module <a href=\"" ++ fileName ++ "\">"
427 ++ modName ++ "</a></tt></td>\n" ++
428 showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
429 showSummary (altTicked modSummary) (altTotal modSummary) ++
430 showSummary (expTicked modSummary) (expTotal modSummary) ++
431 "</tr>\n"
432
433 showTotalSummary :: ModuleSummary -> String
434 showTotalSummary modSummary =
435 "<tr style=\"background: #e0e0e0\">\n" ++
436 "<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>\n" ++
437 showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
438 showSummary (altTicked modSummary) (altTotal modSummary) ++
439 showSummary (expTicked modSummary) (expTotal modSummary) ++
440 "</tr>\n"
441
442 showSummary :: (Integral t, Show t) => t -> t -> String
443 showSummary ticked total =
444 "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
445 "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
446 "<td width=100>" ++
447 (case percent ticked total of
448 Nothing -> "&nbsp;"
449 Just w -> bar w "bar"
450 ) ++ "</td>"
451 where
452 showP Nothing = "-&nbsp;"
453 showP (Just x) = show x ++ "%"
454 bar 0 _ = bar 100 "invbar"
455 bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
456 "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
457 "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
458 "</table></td></tr></table>"
459
460 percent :: (Integral a) => a -> a -> Maybe a
461 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
462
463
464 instance Monoid ModuleSummary where
465 mempty = ModuleSummary
466 { expTicked = 0
467 , expTotal = 0
468 , topFunTicked = 0
469 , topFunTotal = 0
470 , altTicked = 0
471 , altTotal = 0
472 }
473 mappend (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
474 (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
475 = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
476
477
478 ------------------------------------------------------------------------------
479
480 writeFileUsing :: String -> String -> IO ()
481 writeFileUsing filename text = do
482 -- We need to check for the dest_dir each time, because we use sub-dirs for
483 -- packages, and a single .tix file might contain information about
484 -- many package.
485
486 -- create the dest_dir if needed
487 createDirectoryIfMissing True (takeDirectory filename)
488
489 writeFile filename text
490
491 ------------------------------------------------------------------------------
492 -- global color pallete
493
494 red,green,yellow :: String
495 red = "#f20913"
496 green = "#60de51"
497 yellow = "yellow"
498