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,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
  25   , altHighlightOpt
  26 #if __GLASGOW_HASKELL__ >= 604
  27   , destDirOpt
  28 #endif
  29   ]
  30
  31 markup_plugin = Plugin { name = "markup"
  32                        , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
  33                        , options = markup_options
  34                        , summary = "Markup Haskell source with program coverage"
  35                        , implementation = markup_main
  36                        , init_flags = default_flags
  37                        , final_flags = default_final_flags
  38                        }
  39
  40 ------------------------------------------------------------------------------
  41
  42 markup_main :: Flags -> [String] -> IO ()
  43 markup_main flags (prog:modNames) = do
  44   let hpcflags1 = flags
  45                 { includeMods = Set.fromList modNames
  46                                    `Set.union`
  47                                 includeMods flags }
  48   let Flags
  49        { hpcDirs = hpcDirs
  50        , hsDirs = theHsPath
  51        , funTotals = theFunTotals
  52        , altHighlight = invertOutput
  53        , destDir = dest_dir
  54        }  = hpcflags1
  55
  56   mtix <- readTix (getTixFileName prog)
  57   Tix tixs <- case mtix of
  58     Nothing -> error $ "unable to find tix file for: " ++ prog
  59     Just a -> return a
  60
  61 #if __GLASGOW_HASKELL__ >= 604
  62   -- create the dest_dir if needed
  63   createDirectoryIfMissing True dest_dir
  64 #endif
  65
  66   mods <-
  67      sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput
  68               | tix <- tixs
  69               , allowModule hpcflags1 (tixModuleName tix)
  70               ]
  71
  72   let index_name = "hpc_index"
  73       index_fun  = "hpc_index_fun"
  74       index_alt  = "hpc_index_alt"
  75       index_exp  = "hpc_index_exp"
  76
  77   let writeSummary name cmp = do
  78         let mods' = sortBy cmp mods
  79
  80
  81
  82
  83         putStrLn $ "Writing: " ++ (name ++ ".html")
  84         writeFile (dest_dir ++ "/" ++ name ++ ".html") $
  85             "<html>" ++
  86             "<style type=\"text/css\">" ++
  87             "table.bar { background-color: #f25913; }\n" ++
  88             "td.bar { background-color: #60de51;  }\n" ++
  89             "td.invbar { background-color: #f25913;  }\n" ++
  90             "table.dashboard { border-collapse: collapse  ; border: solid 1px black }\n" ++
  91             ".dashboard td { border: solid 1px black }\n" ++
  92             ".dashboard th { border: solid 1px black }\n" ++
  93             "</style>\n" ++
  94             "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
  95             "<tr>" ++
  96             "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
  97             "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
  98             "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
  99             "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
 100             "</tr>" ++
 101             "<tr>" ++
 102             "<th>%</th>" ++
 103             "<th colspan=2>covered / total</th>" ++
 104             "<th>%</th>" ++
 105             "<th colspan=2>covered / total</th>" ++
 106             "<th>%</th>" ++
 107             "<th colspan=2>covered / total</th>" ++
 108             "</tr>" ++
 109             concat [ showModuleSummary (modName,fileName,summary)
 110                    | (modName,fileName,summary) <- mods'
 111                    ] ++
 112             "<tr></tr>" ++
 113             showTotalSummary (foldr1 combineSummary
 114                                  [ summary
 115                                  | (_,_,summary) <- mods'
 116                                  ])
 117                    ++ "</table></html>\n"
 118
 119   writeSummary index_name  $ \ (n1,_,_) (n2,_,_) -> compare n1 n2
 120
 121   writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
 122         compare (percent (topFunTicked s2) (topFunTotal s2))
 123                 (percent (topFunTicked s1) (topFunTotal s1))
 124
 125   writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
 126         compare (percent (altTicked s2) (altTotal s2))
 127                 (percent (altTicked s1) (altTotal s1))
 128
 129   writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
 130         compare (percent (expTicked s2) (expTotal s2))
 131                 (percent (expTicked s1) (expTotal s1))
 132
 133
 134 markup_main flags [] = error $ "no .tix file or executable name specified"
 135
 136 genHtmlFromMod
 137   :: String
 138   -> [FilePath]
 139   -> TixModule
 140   -> Bool
 141   -> [String]
 142   -> Bool
 143   -> IO (String, [Char], ModuleSummary)
 144 genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
 145   let modName0 = tixModuleName tix
 146
 147   (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0
 148
 149   let arr_tix :: Array Int Integer
 150       arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
 151               $ tixModuleTixs tix
 152
 153   let tickedWith :: Int -> Integer
 154       tickedWith n = arr_tix ! n
 155
 156       isTicked n = tickedWith n /= 0
 157
 158   let info = [ (pos,theMarkup)
 159              | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
 160              , let binBox = case (isTicked gid,isTicked (gid+1)) of
 161                                (False,False) -> []
 162                                (True,False)  -> [TickedOnlyTrue]
 163                                (False,True)  -> [TickedOnlyFalse]
 164                                (True,True)   -> []
 165              , let tickBox = if isTicked gid
 166                              then [IsTicked]
 167                              else [NotTicked]
 168              , theMarkup <- case boxLabel of
 169                                   ExpBox {} -> tickBox
 170                                   TopLevelBox {}
 171                                             -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
 172                                   LocalBox {}   -> tickBox
 173                                   BinBox _ True -> binBox
 174                                   _             -> []
 175              ]
 176
 177
 178   let summary = foldr (.) id
 179              [ \ st ->
 180                case boxLabel of
 181                  ExpBox False
 182                         -> st { expTicked = ticked (expTicked st)
 183                               , expTotal = succ (expTotal st)
 184                               }
 185                  ExpBox True
 186                         -> st { expTicked = ticked (expTicked st)
 187                               , expTotal = succ (expTotal st)
 188                               , altTicked = ticked (altTicked st)
 189                               , altTotal = succ (altTotal st)
 190                               }
 191                  TopLevelBox _ ->
 192                            st { topFunTicked = ticked (topFunTicked st)
 193                               , topFunTotal = succ (topFunTotal st)
 194                               }
 195                  _ -> st
 196              | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
 197              , let ticked = if isTicked gid
 198                             then succ
 199                             else id
 200              ] $ ModuleSummary
 201                   { expTicked = 0
 202                   , expTotal  = 0
 203                   , topFunTicked = 0
 204                   , topFunTotal  = 0
 205                   , altTicked = 0
 206                   , altTotal  = 0
 207                   }
 208
 209   -- add prefix to modName argument
 210   content <- readFileFromPath origFile theHsPath
 211
 212   let content' = markup tabStop info content
 213   let show' = reverse . take 5 . (++ "       ") . reverse . show
 214   let addLine n xs = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs
 215   let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
 216   let fileName = modName0 ++ ".hs.html"
 217   putStrLn $ "Writing: " ++ fileName
 218   writeFile (dest_dir ++ "/" ++ fileName) $
 219             unlines [ "<html><style type=\"text/css\">",
 220                      "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
 221                      if invertOutput
 222                      then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
 223                      else "span.nottickedoff { background: " ++ yellow ++ "}",
 224                      if invertOutput
 225                      then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
 226                      else "span.istickedoff { background: white }",
 227                      "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
 228                      "span.tickonlytrue  { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
 229                      "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
 230                      if invertOutput
 231                      then "span.decl { font-weight: bold; background: #d0c0ff }"
 232                      else "span.decl { font-weight: bold }",
 233                      "span.spaces    { background: white }",
 234                      "</style>",
 235                      "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n";
 236
 237   summary `seq` return (modName0,fileName,summary)
 238
 239 data Loc = Loc !Int !Int
 240          deriving (Eq,Ord,Show)
 241
 242 data Markup
 243      = NotTicked
 244      | TickedOnlyTrue
 245      | TickedOnlyFalse
 246      | IsTicked
 247      | TopLevelDecl
 248            Bool     -- display entry totals
 249            Integer
 250      deriving (Eq,Show)
 251
 252 markup    :: Int                -- ^tabStop
 253           -> [(HpcPos,Markup)]  -- random list of tick location pairs
 254           -> String             -- text to mark up
 255           -> String
 256 markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
 257   where
 258     tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
 259                | (pos,mark) <- mix
 260                , let (ln1,c1,ln2,c2) = fromHpcPos pos
 261                ]
 262     sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
 263                               (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs
 264
 265 addMarkup :: Int                -- tabStop
 266           -> String             -- text to mark up
 267           -> Loc                -- current location
 268           -> [(Loc,Markup)]     -- stack of open ticks, with closing location
 269           -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
 270           -> String
 271
 272 -- check the pre-condition.
 273 --addMarkup tabStop cs loc os ticks
 274 --   | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os
 275
 276 --addMarkup tabStop cs loc os@(_:_) ticks
 277 --   | trace (show (loc,os,take 10 ticks)) False = undefined
 278
 279 -- close all open ticks, if we have reached the end
 280 addMarkup _ [] _loc os [] =
 281   concatMap (const closeTick) os
 282 addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
 283   closeTick ++ addMarkup tabStop cs loc os ticks
 284
 285 --addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
 286 --   openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks
 287
 288 addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
 289   case os of
 290   ((_,tik'):_)
 291     | not (allowNesting tik0 tik')
 292     -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
 293   _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
 294   where
 295
 296   addTo (t,tik) []             = [(t,tik)]
 297   addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs
 298                                | t > t'  = (t',tik):(t',tik'):xs
 299
 300 addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
 301           -- throw away this tick, because it is from a previous place ??
 302           addMarkup tabStop0 cs loc os ticks
 303
 304 addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
 305           | ln == ln2 && col < col2
 306           = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
 307 addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
 308   if c0=='\n' && os/=[] then
 309     concatMap (const closeTick) (downToTopLevel os) ++
 310     c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
 311     concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
 312     addMarkup tabStop0 cs' loc' os ticks
 313   else if c0=='\t' then
 314     expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
 315   else
 316     escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
 317   where
 318   (w,cs') = span (`elem` " \t") cs
 319   loc' = foldl (flip incBy) loc (c0:w)
 320   escape '>' = "&gt;"
 321   escape '<' = "&lt;"
 322   escape '"' = "&quot;"
 323   escape '&' = "&amp;"
 324   escape c  = [c]
 325
 326   expand :: Int -> String -> String
 327   expand _ ""       = ""
 328   expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
 329     where
 330     c' = tabStopAfter 8 c
 331   expand c (' ':s)  = ' ' : expand (c+1) s
 332   expand _ _        = error "bad character in string for expansion"
 333
 334   incBy :: Char -> Loc -> Loc
 335   incBy '\n' (Loc ln _c) = Loc (succ ln) 1
 336   incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
 337   incBy _    (Loc ln c) = Loc ln (succ c)
 338
 339   tabStopAfter :: Int -> Int -> Int
 340   tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])
 341
 342
 343 addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)
 344
 345 openTick :: Markup -> String
 346 openTick NotTicked       = "<span class=\"nottickedoff\">"
 347 openTick IsTicked       = "<span class=\"istickedoff\">"
 348 openTick TickedOnlyTrue  = "<span class=\"tickonlytrue\">"
 349 openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
 350 openTick (TopLevelDecl False _) = openTopDecl
 351 openTick (TopLevelDecl True 0)
 352          = "<span class=\"funcount\">-- never entered</span>" ++
 353            openTopDecl
 354 openTick (TopLevelDecl True 1)
 355          = "<span class=\"funcount\">-- entered once</span>" ++
 356            openTopDecl
 357 openTick (TopLevelDecl True n0)
 358          = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl
 359   where showBigNum n | n <= 9999 = show n
 360                      | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
 361         showBigNum' n | n <= 999 = show n
 362                       | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
 363         showWith n = take 3 $ reverse $ ("000" ++) $ reverse $ show n
 364
 365 closeTick :: String
 366 closeTick = "</span>"
 367
 368 openTopDecl :: String
 369 openTopDecl = "<span class=\"decl\">"
 370
 371 downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
 372 downToTopLevel ((_,TopLevelDecl {}):_) = []
 373 downToTopLevel (o : os)               = o : downToTopLevel os
 374 downToTopLevel []                     = []
 375
 376
 377 -- build in logic for nesting bin boxes
 378
 379 allowNesting :: Markup  -- innermost
 380             -> Markup   -- outermost
 381             -> Bool
 382 allowNesting n m               | n == m = False -- no need to double nest
 383 allowNesting IsTicked TickedOnlyFalse   = False
 384 allowNesting IsTicked TickedOnlyTrue    = False
 385 allowNesting _ _                        = True
 386
 387 ------------------------------------------------------------------------------
 388
 389 data ModuleSummary = ModuleSummary
 390      { expTicked :: !Int
 391      , expTotal  :: !Int
 392      , topFunTicked :: !Int
 393      , topFunTotal  :: !Int
 394      , altTicked :: !Int
 395      , altTotal  :: !Int
 396      }
 397      deriving (Show)
 398
 399
 400 showModuleSummary :: (String, String, ModuleSummary) -> String
 401 showModuleSummary (modName,fileName,summary) =
 402   "<tr>\n" ++
 403   "<td>&nbsp;&nbsp;<tt>module <a href=\"" ++ fileName ++ "\">"
 404                               ++ modName ++ "</a></tt></td>\n" ++
 405    showSummary (topFunTicked summary) (topFunTotal summary) ++
 406    showSummary (altTicked summary) (altTotal summary) ++
 407    showSummary (expTicked summary) (expTotal summary) ++
 408   "</tr>\n"
 409
 410 showTotalSummary :: ModuleSummary -> String
 411 showTotalSummary summary =
 412   "<tr style=\"background: #e0e0e0\">\n" ++
 413   "<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>\n" ++
 414    showSummary (topFunTicked summary) (topFunTotal summary) ++
 415    showSummary (altTicked summary) (altTotal summary) ++
 416    showSummary (expTicked summary) (expTotal summary) ++
 417   "</tr>\n"
 418
 419 showSummary :: (Integral t) => t -> t -> String
 420 showSummary ticked total =
 421                 "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
 422                 "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
 423                 "<td width=100>" ++
 424                     (case percent ticked total of
 425                        Nothing -> "&nbsp;"
 426                        Just w -> bar w "bar"
 427                      )  ++ "</td>"
 428      where
 429         showP Nothing = "-&nbsp;"
 430         showP (Just x) = show x ++ "%"
 431         bar 0 inner = bar 100 "invbar"
 432         bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
 433                          "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
 434                               "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
 435                               "</table></td></tr></table>"
 436
 437 percent :: (Integral a) => a -> a -> Maybe a
 438 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
 439
 440
 441 combineSummary :: ModuleSummary -> ModuleSummary -> ModuleSummary
 442 combineSummary (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
 443                (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
 444   = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
 445
 446 ------------------------------------------------------------------------------
 447 -- global color pallete
 448
 449 red,green,yellow :: String
 450 red    = "#f20913"
 451 green  = "#60de51"
 452 yellow = "yellow"
 453
 454 ------------------------------------------------------------------------------
 455
 456 readFileFromPath :: String -> [String] -> IO String
 457 readFileFromPath filename@('/':_) _ = readFile filename
 458 readFileFromPath filename path0 = readTheFile path0
 459   where
 460         readTheFile :: [String] -> IO String
 461         readTheFile [] = error $ "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)