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