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 Data.Set as Set
  20
  21 ------------------------------------------------------------------------------
  22
  23 markup_options =
  24   [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
  25   , altHighlightOpt
  26   , destDirOpt
  27   ]
  28
  29 markup_plugin = Plugin { name = "markup"
  30                        , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
  31                        , options = markup_options
  32                        , summary = "Markup Haskell source with program coverage"
  33                        , implementation = markup_main
  34                        , init_flags = default_flags
  35                        , final_flags = default_final_flags
  36                        }
  37
  38 ------------------------------------------------------------------------------
  39
  40 markup_main :: Flags -> [String] -> IO ()
  41 markup_main flags (prog:modNames) = do
  42   let hpcflags1 = flags
  43                 { includeMods = Set.fromList modNames
  44                                    `Set.union`
  45                                 includeMods flags }
  46   let Flags
  47        { hpcDirs = hpcDirs
  48        , hsDirs = theHsPath
  49        , funTotals = theFunTotals
  50        , altHighlight = invertOutput
  51        , destDir = dest_dir
  52        }  = hpcflags1
  53
  54   mtix <- readTix (getTixFileName prog)
  55   Tix tixs <- case mtix of
  56     Nothing -> error $ "unable to find tix file for: " ++ prog
  57     Just a -> return a
  58
  59   -- create the dest_dir if needed
  60   createDirectoryIfMissing True dest_dir
  61
  62   mods <-
  63      sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput
  64               | tix <- tixs
  65               , allowModule hpcflags1 (tixModuleName tix)
  66               ]
  67
  68   let index_name = "hpc_index"
  69       index_fun  = "hpc_index_fun"
  70       index_alt  = "hpc_index_alt"
  71       index_exp  = "hpc_index_exp"
  72
  73   let writeSummary name cmp = do
  74         let mods' = sortBy cmp mods
  75
  76
  77
  78
  79         putStrLn $ "Writing: " ++ (name ++ ".html")
  80         writeFile (dest_dir ++ "/" ++ name ++ ".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,summary)
 106                    | (modName,fileName,summary) <- mods'
 107                    ] ++
 108             "<tr></tr>" ++
 109             showTotalSummary (foldr1 combineSummary
 110                                  [ summary
 111                                  | (_,_,summary) <- 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 flags [] = error $ "no .tix file or executable name specified"
 131
 132 genHtmlFromMod
 133   :: String
 134   -> [FilePath]
 135   -> TixModule
 136   -> Bool
 137   -> [String]
 138   -> Bool
 139   -> IO (String, [Char], ModuleSummary)
 140 genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
 141   let modName0 = tixModuleName tix
 142
 143   (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0
 144
 145   let arr_tix :: Array Int Integer
 146       arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
 147               $ tixModuleTixs tix
 148
 149   let tickedWith :: Int -> Integer
 150       tickedWith n = arr_tix ! n
 151
 152       isTicked n = tickedWith n /= 0
 153
 154   let info = [ (pos,theMarkup)
 155              | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
 156              , let binBox = case (isTicked gid,isTicked (gid+1)) of
 157                                (False,False) -> []
 158                                (True,False)  -> [TickedOnlyTrue]
 159                                (False,True)  -> [TickedOnlyFalse]
 160                                (True,True)   -> []
 161              , let tickBox = if isTicked gid
 162                              then [IsTicked]
 163                              else [NotTicked]
 164              , theMarkup <- case boxLabel of
 165                                   ExpBox {} -> tickBox
 166                                   TopLevelBox {}
 167                                             -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
 168                                   LocalBox {}   -> tickBox
 169                                   BinBox _ True -> binBox
 170                                   _             -> []
 171              ]
 172
 173
 174   let summary = foldr (.) id
 175              [ \ st ->
 176                case boxLabel of
 177                  ExpBox False
 178                         -> st { expTicked = ticked (expTicked st)
 179                               , expTotal = succ (expTotal st)
 180                               }
 181                  ExpBox True
 182                         -> st { expTicked = ticked (expTicked st)
 183                               , expTotal = succ (expTotal st)
 184                               , altTicked = ticked (altTicked st)
 185                               , altTotal = succ (altTotal st)
 186                               }
 187                  TopLevelBox _ ->
 188                            st { topFunTicked = ticked (topFunTicked st)
 189                               , topFunTotal = succ (topFunTotal st)
 190                               }
 191                  _ -> st
 192              | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
 193              , let ticked = if isTicked gid
 194                             then succ
 195                             else id
 196              ] $ ModuleSummary
 197                   { expTicked = 0
 198                   , expTotal  = 0
 199                   , topFunTicked = 0
 200                   , topFunTotal  = 0
 201                   , altTicked = 0
 202                   , altTotal  = 0
 203                   }
 204
 205   -- add prefix to modName argument
 206   content <- readFileFromPath 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   summary `seq` return (modName0,fileName,summary)
 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                                | t > t'  = (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,summary) =
 398   "<tr>\n" ++
 399   "<td>&nbsp;&nbsp;<tt>module <a href=\"" ++ fileName ++ "\">"
 400                               ++ modName ++ "</a></tt></td>\n" ++
 401    showSummary (topFunTicked summary) (topFunTotal summary) ++
 402    showSummary (altTicked summary) (altTotal summary) ++
 403    showSummary (expTicked summary) (expTotal summary) ++
 404   "</tr>\n"
 405
 406 showTotalSummary :: ModuleSummary -> String
 407 showTotalSummary summary =
 408   "<tr style=\"background: #e0e0e0\">\n" ++
 409   "<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>\n" ++
 410    showSummary (topFunTicked summary) (topFunTotal summary) ++
 411    showSummary (altTicked summary) (altTotal summary) ++
 412    showSummary (expTicked summary) (expTotal summary) ++
 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 inner = 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 combineSummary :: ModuleSummary -> ModuleSummary -> ModuleSummary
 438 combineSummary (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
 439                (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
 440   = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
 441
 442 ------------------------------------------------------------------------------
 443 -- global color pallete
 444
 445 red,green,yellow :: String
 446 red    = "#f20913"
 447 green  = "#60de51"
 448 yellow = "yellow"
 449
 450 ------------------------------------------------------------------------------
 451
 452 readFileFromPath :: String -> [String] -> IO String
 453 readFileFromPath filename@('/':_) _ = readFile filename
 454 readFileFromPath filename path0 = readTheFile path0
 455   where
 456         readTheFile :: [String] -> IO String
 457         readTheFile [] = error $ "could not find " ++ show filename
 458                                  ++ " in path " ++ show path0
 459         readTheFile (dir:dirs) =
 460                 catch (do str <- readFile (dir ++ "/" ++ filename)
 461                           return str)
 462                       (\ _ -> readTheFile dirs)