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.Directory
  15 import Data.List
  16 import Data.Maybe(fromJust)
  17 import Data.Array
  18 import qualified HpcSet as Set
  19
  20 ------------------------------------------------------------------------------
  21
  22 markup_options =
  23   [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
  24   , altHighlightOpt
  25 #if __GLASGOW_HASKELL__ >= 604
  26   , destDirOpt
  27 #endif
  28   ]
  29
  30 markup_plugin = Plugin { name = "markup"
  31                        , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
  32                        , options = markup_options
  33                        , summary = "Markup Haskell source with program coverage"
  34                        , implementation = markup_main
  35                        , init_flags = default_flags
  36                        , final_flags = default_final_flags
  37                        }
  38
  39 ------------------------------------------------------------------------------
  40
  41 markup_main :: Flags -> [String] -> IO ()
  42 markup_main flags (prog:modNames) = do
  43   let hpcflags1 = flags
  44                 { includeMods = Set.fromList modNames
  45                                    `Set.union`
  46                                 includeMods flags }
  47   let Flags
  48        { hpcDirs = hpcDirs
  49        , hsDirs = theHsPath
  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 -> error $ "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 hpcDirs tix theFunTotals theHsPath 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 [] = error $ "no .tix file or executable name specified"
 134
 135 genHtmlFromMod
 136   :: String
 137   -> [FilePath]
 138   -> TixModule
 139   -> Bool
 140   -> [String]
 141   -> Bool
 142   -> IO (String, [Char], ModuleSummary)
 143 genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
 144   let modName0 = tixModuleName tix
 145
 146   (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs 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 [] = error $ "could not find " ++ show filename
 461                                  ++ " in path " ++ show path0
 462         readTheFile (dir:dirs) =
 463                 catch (do str <- readFile (dir ++ "/" ++ filename)
 464                           return str)
 465                       (\ _ -> readTheFile dirs)