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