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