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   mods <-
  64      sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
  65               | tix <- tixs
  66               , allowModule hpcflags1 (tixModuleName tix)
  67               ]
  68
  69   let index_name = "hpc_index"
  70       index_fun  = "hpc_index_fun"
  71       index_alt  = "hpc_index_alt"
  72       index_exp  = "hpc_index_exp"
  73
  74   let writeSummary filename cmp = do
  75         let mods' = sortBy cmp mods
  76
  77         putStrLn $ "Writing: " ++ (filename ++ ".html")
  78
  79         writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $
  80             "<html>" ++
  81             "<style type=\"text/css\">" ++
  82             "table.bar { background-color: #f25913; }\n" ++
  83             "td.bar { background-color: #60de51;  }\n" ++
  84             "td.invbar { background-color: #f25913;  }\n" ++
  85             "table.dashboard { border-collapse: collapse  ; border: solid 1px black }\n" ++
  86             ".dashboard td { border: solid 1px black }\n" ++
  87             ".dashboard th { border: solid 1px black }\n" ++
  88             "</style>\n" ++
  89             "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
  90             "<tr>" ++
  91             "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
  92             "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
  93             "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
  94             "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
  95             "</tr>" ++
  96             "<tr>" ++
  97             "<th>%</th>" ++
  98             "<th colspan=2>covered / total</th>" ++
  99             "<th>%</th>" ++
 100             "<th colspan=2>covered / total</th>" ++
 101             "<th>%</th>" ++
 102             "<th colspan=2>covered / total</th>" ++
 103             "</tr>" ++
 104             concat [ showModuleSummary (modName,fileName,modSummary)
 105                    | (modName,fileName,modSummary) <- mods'
 106                    ] ++
 107             "<tr></tr>" ++
 108             showTotalSummary (mconcat
 109                                  [ modSummary
 110                                  | (_,_,modSummary) <- mods'
 111                                  ])
 112                    ++ "</table></html>\n"
 113
 114   writeSummary index_name  $ \ (n1,_,_) (n2,_,_) -> compare n1 n2
 115
 116   writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
 117         compare (percent (topFunTicked s2) (topFunTotal s2))
 118                 (percent (topFunTicked s1) (topFunTotal s1))
 119
 120   writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
 121         compare (percent (altTicked s2) (altTotal s2))
 122                 (percent (altTicked s1) (altTotal s1))
 123
 124   writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
 125         compare (percent (expTicked s2) (expTotal s2))
 126                 (percent (expTicked s1) (expTotal s1))
 127
 128
 129 markup_main _ []
 130     = hpcError markup_plugin $ "no .tix file or executable name specified"
 131
 132 genHtmlFromMod
 133   :: String
 134   -> Flags
 135   -> TixModule
 136   -> Bool
 137   -> Bool
 138   -> IO (String, [Char], ModuleSummary)
 139 genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
 140   let theHsPath = srcDirs flags
 141   let modName0 = tixModuleName tix
 142
 143   (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix)
 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 modSummary = 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              ] $ mempty
 197
 198   -- add prefix to modName argument
 199   content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath
 200
 201   let content' = markup tabStop info content
 202   let show' = reverse . take 5 . (++ "       ") . reverse . show
 203   let addLine n xs = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs
 204   let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
 205   let fileName = modName0 ++ ".hs.html"
 206   putStrLn $ "Writing: " ++ fileName
 207   writeFileUsing (dest_dir ++ "/" ++ fileName) $
 208             unlines [ "<html><style type=\"text/css\">",
 209                      "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
 210                      if invertOutput
 211                      then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
 212                      else "span.nottickedoff { background: " ++ yellow ++ "}",
 213                      if invertOutput
 214                      then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
 215                      else "span.istickedoff { background: white }",
 216                      "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
 217                      "span.tickonlytrue  { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
 218                      "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
 219                      if invertOutput
 220                      then "span.decl { font-weight: bold; background: #d0c0ff }"
 221                      else "span.decl { font-weight: bold }",
 222                      "span.spaces    { background: white }",
 223                      "</style>",
 224                      "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n";
 225
 226   modSummary `seq` return (modName0,fileName,modSummary)
 227
 228 data Loc = Loc !Int !Int
 229          deriving (Eq,Ord,Show)
 230
 231 data Markup
 232      = NotTicked
 233      | TickedOnlyTrue
 234      | TickedOnlyFalse
 235      | IsTicked
 236      | TopLevelDecl
 237            Bool     -- display entry totals
 238            Integer
 239      deriving (Eq,Show)
 240
 241 markup    :: Int                -- ^tabStop
 242           -> [(HpcPos,Markup)]  -- random list of tick location pairs
 243           -> String             -- text to mark up
 244           -> String
 245 markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
 246   where
 247     tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
 248                | (pos,mark) <- mix
 249                , let (ln1,c1,ln2,c2) = fromHpcPos pos
 250                ]
 251     sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
 252                               (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs
 253
 254 addMarkup :: Int                -- tabStop
 255           -> String             -- text to mark up
 256           -> Loc                -- current location
 257           -> [(Loc,Markup)]     -- stack of open ticks, with closing location
 258           -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
 259           -> String
 260
 261 -- check the pre-condition.
 262 --addMarkup tabStop cs loc os ticks
 263 --   | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os
 264
 265 --addMarkup tabStop cs loc os@(_:_) ticks
 266 --   | trace (show (loc,os,take 10 ticks)) False = undefined
 267
 268 -- close all open ticks, if we have reached the end
 269 addMarkup _ [] _loc os [] =
 270   concatMap (const closeTick) os
 271 addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
 272   closeTick ++ addMarkup tabStop cs loc os ticks
 273
 274 --addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
 275 --   openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks
 276
 277 addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
 278   case os of
 279   ((_,tik'):_)
 280     | not (allowNesting tik0 tik')
 281     -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
 282   _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
 283   where
 284
 285   addTo (t,tik) []             = [(t,tik)]
 286   addTo (t,tik) ((t',tik'):xs) | t <= t'   = (t,tik):(t',tik'):xs
 287                                | otherwise = (t',tik):(t',tik'):xs
 288
 289 addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
 290           -- throw away this tick, because it is from a previous place ??
 291           addMarkup tabStop0 cs loc os ticks
 292
 293 addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
 294           | ln == ln2 && col < col2
 295           = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
 296 addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
 297   if c0=='\n' && os/=[] then
 298     concatMap (const closeTick) (downToTopLevel os) ++
 299     c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
 300     concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
 301     addMarkup tabStop0 cs' loc' os ticks
 302   else if c0=='\t' then
 303     expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
 304   else
 305     escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
 306   where
 307   (w,cs') = span (`elem` " \t") cs
 308   loc' = foldl (flip incBy) loc (c0:w)
 309   escape '>' = "&gt;"
 310   escape '<' = "&lt;"
 311   escape '"' = "&quot;"
 312   escape '&' = "&amp;"
 313   escape c  = [c]
 314
 315   expand :: Int -> String -> String
 316   expand _ ""       = ""
 317   expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
 318     where
 319     c' = tabStopAfter 8 c
 320   expand c (' ':s)  = ' ' : expand (c+1) s
 321   expand _ _        = error "bad character in string for expansion"
 322
 323   incBy :: Char -> Loc -> Loc
 324   incBy '\n' (Loc ln _c) = Loc (succ ln) 1
 325   incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
 326   incBy _    (Loc ln c) = Loc ln (succ c)
 327
 328   tabStopAfter :: Int -> Int -> Int
 329   tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])
 330
 331
 332 addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)
 333
 334 openTick :: Markup -> String
 335 openTick NotTicked       = "<span class=\"nottickedoff\">"
 336 openTick IsTicked       = "<span class=\"istickedoff\">"
 337 openTick TickedOnlyTrue  = "<span class=\"tickonlytrue\">"
 338 openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
 339 openTick (TopLevelDecl False _) = openTopDecl
 340 openTick (TopLevelDecl True 0)
 341          = "<span class=\"funcount\">-- never entered</span>" ++
 342            openTopDecl
 343 openTick (TopLevelDecl True 1)
 344          = "<span class=\"funcount\">-- entered once</span>" ++
 345            openTopDecl
 346 openTick (TopLevelDecl True n0)
 347          = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl
 348   where showBigNum n | n <= 9999 = show n
 349                      | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
 350         showBigNum' n | n <= 999 = show n
 351                       | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000)
 352         showWith n = take 3 $ reverse $ ("000" ++) $ reverse $ show n
 353
 354 closeTick :: String
 355 closeTick = "</span>"
 356
 357 openTopDecl :: String
 358 openTopDecl = "<span class=\"decl\">"
 359
 360 downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
 361 downToTopLevel ((_,TopLevelDecl {}):_) = []
 362 downToTopLevel (o : os)               = o : downToTopLevel os
 363 downToTopLevel []                     = []
 364
 365
 366 -- build in logic for nesting bin boxes
 367
 368 allowNesting :: Markup  -- innermost
 369             -> Markup   -- outermost
 370             -> Bool
 371 allowNesting n m               | n == m = False -- no need to double nest
 372 allowNesting IsTicked TickedOnlyFalse   = False
 373 allowNesting IsTicked TickedOnlyTrue    = False
 374 allowNesting _ _                        = True
 375
 376 ------------------------------------------------------------------------------
 377
 378 data ModuleSummary = ModuleSummary
 379      { expTicked :: !Int
 380      , expTotal  :: !Int
 381      , topFunTicked :: !Int
 382      , topFunTotal  :: !Int
 383      , altTicked :: !Int
 384      , altTotal  :: !Int
 385      }
 386      deriving (Show)
 387
 388
 389 showModuleSummary :: (String, String, ModuleSummary) -> String
 390 showModuleSummary (modName,fileName,modSummary) =
 391   "<tr>\n" ++
 392   "<td>&nbsp;&nbsp;<tt>module <a href=\"" ++ fileName ++ "\">"
 393                               ++ modName ++ "</a></tt></td>\n" ++
 394    showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
 395    showSummary (altTicked modSummary) (altTotal modSummary) ++
 396    showSummary (expTicked modSummary) (expTotal modSummary) ++
 397   "</tr>\n"
 398
 399 showTotalSummary :: ModuleSummary -> String
 400 showTotalSummary modSummary =
 401   "<tr style=\"background: #e0e0e0\">\n" ++
 402   "<th align=left>&nbsp;&nbsp;Program Coverage Total</tt></th>\n" ++
 403    showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
 404    showSummary (altTicked modSummary) (altTotal modSummary) ++
 405    showSummary (expTicked modSummary) (expTotal modSummary) ++
 406   "</tr>\n"
 407
 408 showSummary :: (Integral t) => t -> t -> String
 409 showSummary ticked total =
 410                 "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
 411                 "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
 412                 "<td width=100>" ++
 413                     (case percent ticked total of
 414                        Nothing -> "&nbsp;"
 415                        Just w -> bar w "bar"
 416                      )  ++ "</td>"
 417      where
 418         showP Nothing = "-&nbsp;"
 419         showP (Just x) = show x ++ "%"
 420         bar 0 _     = bar 100 "invbar"
 421         bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
 422                          "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
 423                               "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
 424                               "</table></td></tr></table>"
 425
 426 percent :: (Integral a) => a -> a -> Maybe a
 427 percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
 428
 429
 430 instance Monoid ModuleSummary where
 431   mempty = ModuleSummary
 432                   { expTicked = 0
 433                   , expTotal  = 0
 434                   , topFunTicked = 0
 435                   , topFunTotal  = 0
 436                   , altTicked = 0
 437                   , altTotal  = 0
 438                   }
 439   mappend (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
 440           (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
 441      = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
 442
 443
 444 ------------------------------------------------------------------------------
 445
 446 writeFileUsing :: String -> String -> IO ()
 447 writeFileUsing filename text = do
 448   let dest_dir = reverse . dropWhile (\ x -> x /= '/') . reverse $ filename
 449
 450 -- We need to check for the dest_dir each time, because we use sub-dirs for
 451 -- packages, and a single .tix file might contain information about
 452 -- many package.
 453
 454 #if __GLASGOW_HASKELL__ >= 604
 455   -- create the dest_dir if needed
 456   createDirectoryIfMissing True dest_dir
 457 #endif
 458
 459   writeFile filename text
 460
 461 ------------------------------------------------------------------------------
 462 -- global color pallete
 463
 464 red,green,yellow :: String
 465 red    = "#f20913"
 466 green  = "#60de51"
 467 yellow = "yellow"
 468