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