Allow -ticky and -prof together
[ghc-hetmet.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 HpcSet 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 #if __GLASGOW_HASKELL__ >= 604 
456   -- create the dest_dir if needed
457   when (not (null dest_dir)) $
458     createDirectoryIfMissing True dest_dir
459 #endif
460
461   writeFile filename text
462
463 ------------------------------------------------------------------------------
464 -- global color pallete
465
466 red,green,yellow :: String
467 red    = "#f20913"
468 green  = "#60de51"
469 yellow = "yellow"
470