1 ---------------------------------------------------------
2 -- The main program for the hpc-markup tool, part of HPC.
3 -- Andy Gill and Colin Runciman, June 2006
4 ---------------------------------------------------------
6 module HpcMarkup (markup_plugin) where
14 import System.Environment
16 import Data.Maybe(fromJust)
18 import qualified Data.Set as Set
20 ------------------------------------------------------------------------------
23 [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
28 markup_plugin = Plugin { name = "markup"
29 , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
30 , options = markup_options
31 , summary = "Markup Haskell source with program coverage"
32 , implementation = markup_main
33 , init_flags = default_flags
34 , final_flags = default_final_flags
37 ------------------------------------------------------------------------------
39 markup_main :: Flags -> [String] -> IO ()
40 markup_main flags (prog:modNames) = do
42 { includeMods = Set.fromList modNames
48 , funTotals = theFunTotals
49 , altHighlight = invertOutput
53 mtix <- readTix (getTixFileName prog)
54 Tix tixs <- case mtix of
55 Nothing -> error $ "unable to find tix file for: " ++ prog
59 sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput
61 , allowModule hpcflags1 (tixModuleName tix)
64 let index_name = "hpc_index"
65 index_fun = "hpc_index_fun"
66 index_alt = "hpc_index_alt"
67 index_exp = "hpc_index_exp"
69 let writeSummary name cmp = do
70 let mods' = sortBy cmp mods
72 putStrLn $ "Writing: " ++ (name ++ ".html")
73 writeFile (dest_dir ++ "/" ++ name ++ ".html") $
75 "<style type=\"text/css\">" ++
76 "table.bar { background-color: #f25913; }\n" ++
77 "td.bar { background-color: #60de51; }\n" ++
78 "table.dashboard { border-collapse: collapse ; border: solid 1px black }\n" ++
79 ".dashboard td { border: solid 1px black }\n" ++
80 ".dashboard th { border: solid 1px black }\n" ++
82 "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
84 "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
85 "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
86 "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
87 "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
91 "<th colspan=2>covered / total</th>" ++
93 "<th colspan=2>covered / total</th>" ++
95 "<th colspan=2>covered / total</th>" ++
97 concat [ showModuleSummary (modName,fileName,summary)
98 | (modName,fileName,summary) <- mods'
101 showTotalSummary (foldr1 combineSummary
103 | (_,_,summary) <- mods'
105 ++ "</table></html>\n"
107 writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2
109 writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
110 compare (percent (topFunTicked s2) (topFunTotal s2))
111 (percent (topFunTicked s1) (topFunTotal s1))
113 writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
114 compare (percent (altTicked s2) (altTotal s2))
115 (percent (altTicked s1) (altTotal s1))
117 writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
118 compare (percent (expTicked s2) (expTotal s2))
119 (percent (expTicked s1) (expTotal s1))
122 markup_main flags [] = error $ "no .tix file or executable name specified"
131 -> IO (String, [Char], ModuleSummary)
132 genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
133 let modName0 = tixModuleName tix
135 (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0
137 let arr_tix :: Array Int Integer
138 arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
141 let tickedWith :: Int -> Integer
142 tickedWith n = arr_tix ! n
144 isTicked n = tickedWith n /= 0
146 let info = [ (pos,theMarkup)
147 | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
148 , let binBox = case (isTicked gid,isTicked (gid+1)) of
150 (True,False) -> [TickedOnlyTrue]
151 (False,True) -> [TickedOnlyFalse]
153 , let tickBox = if isTicked gid
156 , theMarkup <- case boxLabel of
159 -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
160 LocalBox {} -> tickBox
161 BinBox _ True -> binBox
166 let summary = foldr (.) id
170 -> st { expTicked = ticked (expTicked st)
171 , expTotal = succ (expTotal st)
174 -> st { expTicked = ticked (expTicked st)
175 , expTotal = succ (expTotal st)
176 , altTicked = ticked (altTicked st)
177 , altTotal = succ (altTotal st)
180 st { topFunTicked = ticked (topFunTicked st)
181 , topFunTotal = succ (topFunTotal st)
184 | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
185 , let ticked = if isTicked gid
197 -- add prefix to modName argument
198 content <- readFileFromPath origFile theHsPath
200 let content' = markup tabStop info content
201 let show' = reverse . take 5 . (++ " ") . reverse . show
202 let addLine n xs = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs
203 let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
204 let fileName = modName0 ++ ".hs.html"
205 putStrLn $ "Writing: " ++ fileName
206 writeFile (dest_dir ++ "/" ++ fileName) $
207 unlines [ "<html><style type=\"text/css\">",
208 "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
210 then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
211 else "span.nottickedoff { background: " ++ yellow ++ "}",
213 then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
214 else "span.istickedoff { background: white }",
215 "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
216 "span.tickonlytrue { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
217 "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
219 then "span.decl { font-weight: bold; background: #d0c0ff }"
220 else "span.decl { font-weight: bold }",
221 "span.spaces { background: white }",
223 "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n";
225 summary `seq` return (modName0,fileName,summary)
227 data Loc = Loc !Int !Int
228 deriving (Eq,Ord,Show)
236 Bool -- display entry totals
240 markup :: Int -- ^tabStop
241 -> [(HpcPos,Markup)] -- random list of tick location pairs
242 -> String -- text to mark up
244 markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
246 tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
248 , let (ln1,c1,ln2,c2) = fromHpcPos pos
250 sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
251 (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs
253 addMarkup :: Int -- tabStop
254 -> String -- text to mark up
255 -> Loc -- current location
256 -> [(Loc,Markup)] -- stack of open ticks, with closing location
257 -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
260 -- check the pre-condition.
261 --addMarkup tabStop cs loc os ticks
262 -- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os
264 --addMarkup tabStop cs loc os@(_:_) ticks
265 -- | trace (show (loc,os,take 10 ticks)) False = undefined
267 -- close all open ticks, if we have reached the end
268 addMarkup _ [] _loc os [] =
269 concatMap (const closeTick) os
270 addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
271 closeTick ++ addMarkup tabStop cs loc os ticks
273 --addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
274 -- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks
276 addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
279 | not (allowNesting tik0 tik')
280 -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
281 _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
284 addTo (t,tik) [] = [(t,tik)]
285 addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs
286 | t > t' = (t',tik):(t',tik'):xs
288 addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
289 -- throw away this tick, because it is from a previous place ??
290 addMarkup tabStop0 cs loc os ticks
292 addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
293 | ln == ln2 && col < col2
294 = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
295 addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
296 if c0=='\n' && os/=[] then
297 concatMap (const closeTick) (downToTopLevel os) ++
298 c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
299 concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
300 addMarkup tabStop0 cs' loc' os ticks
301 else if c0=='\t' then
302 expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
304 escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
306 (w,cs') = span (`elem` " \t") cs
307 loc' = foldl (flip incBy) loc (c0:w)
310 escape '"' = """
314 expand :: Int -> String -> String
316 expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
318 c' = tabStopAfter 8 c
319 expand c (' ':s) = ' ' : expand (c+1) s
320 expand _ _ = error "bad character in string for expansion"
322 incBy :: Char -> Loc -> Loc
323 incBy '\n' (Loc ln _c) = Loc (succ ln) 1
324 incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
325 incBy _ (Loc ln c) = Loc ln (succ c)
327 tabStopAfter :: Int -> Int -> Int
328 tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])
331 addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)
333 openTick :: Markup -> String
334 openTick NotTicked = "<span class=\"nottickedoff\">"
335 openTick IsTicked = "<span class=\"istickedoff\">"
336 openTick TickedOnlyTrue = "<span class=\"tickonlytrue\">"
337 openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
338 openTick (TopLevelDecl False _) = openTopDecl
339 openTick (TopLevelDecl True 0)
340 = "<span class=\"funcount\">-- never entered</span>" ++
342 openTick (TopLevelDecl True 1)
343 = "<span class=\"funcount\">-- entered once</span>" ++
345 openTick (TopLevelDecl True n0)
346 = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl
347 where showBigNum n | n <= 9999 = show n
348 | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
349 showBigNum' n | n <= 999 = show n
350 | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
351 showWith n = take 3 $ reverse $ ("000" ++) $ reverse $ show n
354 closeTick = "</span>"
356 openTopDecl :: String
357 openTopDecl = "<span class=\"decl\">"
359 downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
360 downToTopLevel ((_,TopLevelDecl {}):_) = []
361 downToTopLevel (o : os) = o : downToTopLevel os
362 downToTopLevel [] = []
365 -- build in logic for nesting bin boxes
367 allowNesting :: Markup -- innermost
368 -> Markup -- outermost
370 allowNesting n m | n == m = False -- no need to double nest
371 allowNesting IsTicked TickedOnlyFalse = False
372 allowNesting IsTicked TickedOnlyTrue = False
373 allowNesting _ _ = True
375 ------------------------------------------------------------------------------
377 data ModuleSummary = ModuleSummary
380 , topFunTicked :: !Int
381 , topFunTotal :: !Int
388 showModuleSummary :: (String, String, ModuleSummary) -> String
389 showModuleSummary (modName,fileName,summary) =
391 "<td> <tt>module <a href=\"" ++ fileName ++ "\">"
392 ++ modName ++ "</a></tt></td>\n" ++
393 showSummary (topFunTicked summary) (topFunTotal summary) ++
394 showSummary (altTicked summary) (altTotal summary) ++
395 showSummary (expTicked summary) (expTotal summary) ++
398 showTotalSummary :: ModuleSummary -> String
399 showTotalSummary summary =
400 "<tr style=\"background: #e0e0e0\">\n" ++
401 "<th align=left> Program Coverage Total</tt></th>\n" ++
402 showSummary (topFunTicked summary) (topFunTotal summary) ++
403 showSummary (altTicked summary) (altTotal summary) ++
404 showSummary (expTicked summary) (expTotal summary) ++
407 showSummary :: (Integral t) => t -> t -> String
408 showSummary ticked total =
409 "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
410 "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
412 (case percent ticked total of
414 Just w -> "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
415 "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
416 "<tr><td height=12 class=\"bar\"></td></tr>" ++
417 "</table></td></tr></table>")
420 showP Nothing = "- "
421 showP (Just x) = show x ++ "%"
423 percent :: (Integral a) => a -> a -> Maybe a
424 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
427 combineSummary :: ModuleSummary -> ModuleSummary -> ModuleSummary
428 combineSummary (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
429 (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
430 = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
432 ------------------------------------------------------------------------------
433 -- global color pallete
435 red,green,yellow :: String
440 ------------------------------------------------------------------------------
442 readFileFromPath :: String -> [String] -> IO String
443 readFileFromPath filename@('/':_) _ = readFile filename
444 readFileFromPath filename path0 = readTheFile path0
446 readTheFile :: [String] -> IO String
447 readTheFile [] = error $ "could not find " ++ show filename
448 ++ " in path " ++ show path0
449 readTheFile (dir:dirs) =
450 catch (do str <- readFile (dir ++ "/" ++ filename)
452 (\ _ -> readTheFile dirs)