ca30471ac48ffa7ceed5a8f801d454e0d7869a65
[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>",
254 concat [
255 "<span class=\"decl\">",
256 "<span class=\"nottickedoff\">never executed</span> ",
257 "<span class=\"tickonlytrue\">always true</span> ",
258 "<span class=\"tickonlyfalse\">always false</span></span>"],
259 "</pre>",
260 "<pre>"] ++ addLines content' ++ "\n</pre>\n</body>\n</html>\n";
261
262
263 modSummary `seq` return (modName0,fileName,modSummary)
264
265 data Loc = Loc !Int !Int
266 deriving (Eq,Ord,Show)
267
268 data Markup
269 = NotTicked
270 | TickedOnlyTrue
271 | TickedOnlyFalse
272 | IsTicked
273 | TopLevelDecl
274 Bool -- display entry totals
275 Integer
276 deriving (Eq,Show)
277
278 markup :: Int -- ^tabStop
279 -> [(HpcPos,Markup)] -- random list of tick location pairs
280 -> String -- text to mark up
281 -> String
282 markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
283 where
284 tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
285 | (pos,mark) <- mix
286 , let (ln1,c1,ln2,c2) = fromHpcPos pos
287 ]
288 sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
289 (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs
290
291 addMarkup :: Int -- tabStop
292 -> String -- text to mark up
293 -> Loc -- current location
294 -> [(Loc,Markup)] -- stack of open ticks, with closing location
295 -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
296 -> String
297
298 -- check the pre-condition.
299 --addMarkup tabStop cs loc os ticks
300 -- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os
301
302 --addMarkup tabStop cs loc os@(_:_) ticks
303 -- | trace (show (loc,os,take 10 ticks)) False = undefined
304
305 -- close all open ticks, if we have reached the end
306 addMarkup _ [] _loc os [] =
307 concatMap (const closeTick) os
308 addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
309 closeTick ++ addMarkup tabStop cs loc os ticks
310
311 --addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
312 -- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks
313
314 addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
315 case os of
316 ((_,tik'):_)
317 | not (allowNesting tik0 tik')
318 -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
319 _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
320 where
321
322 addTo (t,tik) [] = [(t,tik)]
323 addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs
324 | otherwise = (t',tik):(t',tik'):xs
325
326 addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
327 -- throw away this tick, because it is from a previous place ??
328 addMarkup tabStop0 cs loc os ticks
329
330 addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
331 | ln == ln2 && col < col2
332 = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
333 addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
334 if c0=='\n' && os/=[] then
335 concatMap (const closeTick) (downToTopLevel os) ++
336 c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
337 concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
338 addMarkup tabStop0 cs' loc' os ticks
339 else if c0=='\t' then
340 expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
341 else
342 escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
343 where
344 (w,cs') = span (`elem` " \t") cs
345 loc' = foldl (flip incBy) loc (c0:w)
346 escape '>' = "&gt;"
347 escape '<' = "&lt;"
348 escape '"' = "&quot;"
349 escape '&' = "&amp;"
350 escape c = [c]
351
352 expand :: Int -> String -> String
353 expand _ "" = ""
354 expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
355 where
356 c' = tabStopAfter 8 c
357 expand c (' ':s) = ' ' : expand (c+1) s
358 expand _ _ = error "bad character in string for expansion"
359
360 incBy :: Char -> Loc -> Loc
361 incBy '\n' (Loc ln _c) = Loc (succ ln) 1
362 incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
363 incBy _ (Loc ln c) = Loc ln (succ c)
364
365 tabStopAfter :: Int -> Int -> Int
366 tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])
367
368
369 addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)
370
371 openTick :: Markup -> String
372 openTick NotTicked = "<span class=\"nottickedoff\">"
373 openTick IsTicked = "<span class=\"istickedoff\">"
374 openTick TickedOnlyTrue = "<span class=\"tickonlytrue\">"
375 openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
376 openTick (TopLevelDecl False _) = openTopDecl
377 openTick (TopLevelDecl True 0)
378 = "<span class=\"funcount\">-- never entered</span>" ++
379 openTopDecl
380 openTick (TopLevelDecl True 1)
381 = "<span class=\"funcount\">-- entered once</span>" ++
382 openTopDecl
383 openTick (TopLevelDecl True n0)
384 = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl
385 where showBigNum n | n <= 9999 = show n
386 | otherwise = case n `quotRem` 1000 of
387 (q, r) -> showBigNum' q ++ "," ++ showWith r
388 showBigNum' n | n <= 999 = show n
389 | otherwise = case n `quotRem` 1000 of
390 (q, r) -> showBigNum' q ++ "," ++ showWith r
391 showWith n = padLeft 3 '0' $ show n
392
393
394
395 closeTick :: String
396 closeTick = "</span>"
397
398 openTopDecl :: String
399 openTopDecl = "<span class=\"decl\">"
400
401 downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
402 downToTopLevel ((_,TopLevelDecl {}):_) = []
403 downToTopLevel (o : os) = o : downToTopLevel os
404 downToTopLevel [] = []
405
406
407 -- build in logic for nesting bin boxes
408
409 allowNesting :: Markup -- innermost
410 -> Markup -- outermost
411 -> Bool
412 allowNesting n m | n == m = False -- no need to double nest
413 allowNesting IsTicked TickedOnlyFalse = False
414 allowNesting IsTicked TickedOnlyTrue = False
415 allowNesting _ _ = True
416
417 ------------------------------------------------------------------------------
418
419 data ModuleSummary = ModuleSummary
420 { expTicked :: !Int
421 , expTotal :: !Int
422 , topFunTicked :: !Int
423 , topFunTotal :: !Int
424 , altTicked :: !Int
425 , altTotal :: !Int
426 }
427 deriving (Show)
428
429
430 showModuleSummary :: (String, String, ModuleSummary) -> String
431 showModuleSummary (modName,fileName,modSummary) =
432 "<tr>\n" ++
433 "<td>&nbsp;&nbsp;<tt>module <a href=\"" ++ fileName ++ "\">"
434 ++ modName ++ "</a></tt></td>\n" ++
435 showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
436 showSummary (altTicked modSummary) (altTotal modSummary) ++
437 showSummary (expTicked modSummary) (expTotal modSummary) ++
438 "</tr>\n"
439
440 showTotalSummary :: ModuleSummary -> String
441 showTotalSummary modSummary =
442 "<tr style=\"background: #e0e0e0\">\n" ++
443 "<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>\n" ++
444 showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
445 showSummary (altTicked modSummary) (altTotal modSummary) ++
446 showSummary (expTicked modSummary) (expTotal modSummary) ++
447 "</tr>\n"
448
449 showSummary :: (Integral t, Show t) => t -> t -> String
450 showSummary ticked total =
451 "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
452 "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
453 "<td width=100>" ++
454 (case percent ticked total of
455 Nothing -> "&nbsp;"
456 Just w -> bar w "bar"
457 ) ++ "</td>"
458 where
459 showP Nothing = "-&nbsp;"
460 showP (Just x) = show x ++ "%"
461 bar 0 _ = bar 100 "invbar"
462 bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
463 "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
464 "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
465 "</table></td></tr></table>"
466
467 percent :: (Integral a) => a -> a -> Maybe a
468 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
469
470
471 instance Monoid ModuleSummary where
472 mempty = ModuleSummary
473 { expTicked = 0
474 , expTotal = 0
475 , topFunTicked = 0
476 , topFunTotal = 0
477 , altTicked = 0
478 , altTotal = 0
479 }
480 mappend (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
481 (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
482 = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
483
484
485 ------------------------------------------------------------------------------
486
487 writeFileUsing :: String -> String -> IO ()
488 writeFileUsing filename text = do
489 -- We need to check for the dest_dir each time, because we use sub-dirs for
490 -- packages, and a single .tix file might contain information about
491 -- many package.
492
493 -- create the dest_dir if needed
494 createDirectoryIfMissing True (takeDirectory filename)
495
496 writeFile filename text
497
498 ------------------------------------------------------------------------------
499 -- global color pallete
500
501 red,green,yellow :: String
502 red = "#f20913"
503 green = "#60de51"
504 yellow = "yellow"
505