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