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 modName0
 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)