← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to utils/hpc/HpcMarkup.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
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