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