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