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