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