--------------------------------------------------------- -- The main program for the hpc-markup tool, part of HPC. -- Andy Gill and Colin Runciman, June 2006 --------------------------------------------------------- module HpcMarkup (markup_plugin) where import Trace.Hpc.Mix import Trace.Hpc.Tix import Trace.Hpc.Util import HpcFlags import HpcUtils import System.Directory import System.IO (localeEncoding) import Data.List import Data.Maybe(fromJust) import Data.Array import Control.Monad import qualified Data.Set as Set ------------------------------------------------------------------------------ markup_options :: FlagOptSeq markup_options = excludeOpt . includeOpt . srcDirOpt . hpcDirOpt . resetHpcDirsOpt . funTotalsOpt . altHighlightOpt . destDirOpt markup_plugin :: Plugin markup_plugin = Plugin { name = "markup" , usage = "[OPTION] .. [ [ ..]]" , options = markup_options , summary = "Markup Haskell source with program coverage" , implementation = markup_main , init_flags = default_flags , final_flags = default_final_flags } ------------------------------------------------------------------------------ markup_main :: Flags -> [String] -> IO () markup_main flags (prog:modNames) = do let hpcflags1 = flags { includeMods = Set.fromList modNames `Set.union` includeMods flags } let Flags { funTotals = theFunTotals , altHighlight = invertOutput , destDir = dest_dir } = hpcflags1 mtix <- readTix (getTixFileName prog) Tix tixs <- case mtix of Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog Just a -> return a mods <- sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput | tix <- tixs , allowModule hpcflags1 (tixModuleName tix) ] let index_name = "hpc_index" index_fun = "hpc_index_fun" index_alt = "hpc_index_alt" index_exp = "hpc_index_exp" let writeSummary filename cmp = do let mods' = sortBy cmp mods putStrLn $ "Writing: " ++ (filename ++ ".html") writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $ "" ++ "" ++ charEncodingTag ++ "\n" ++ "" ++ "" ++ "\n" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ "" ++ concat [ showModuleSummary (modName,fileName,modSummary) | (modName,fileName,modSummary) <- mods' ] ++ "" ++ showTotalSummary (mconcat [ modSummary | (_,_,modSummary) <- mods' ]) ++ "

module	Top Level Definitions			Alternatives			Expressions
module	%	covered / total		%	covered / total		%	covered / total

\n" writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2 writeSummary index_fun $ \ (_,_,s1) (_,_,s2) -> compare (percent (topFunTicked s2) (topFunTotal s2)) (percent (topFunTicked s1) (topFunTotal s1)) writeSummary index_alt $ \ (_,_,s1) (_,_,s2) -> compare (percent (altTicked s2) (altTotal s2)) (percent (altTicked s1) (altTotal s1)) writeSummary index_exp $ \ (_,_,s1) (_,_,s2) -> compare (percent (expTicked s2) (expTotal s2)) (percent (expTicked s1) (expTotal s1)) markup_main _ [] = hpcError markup_plugin $ "no .tix file or executable name specified" charEncodingTag :: String charEncodingTag = "" -- Add characters to the left of a string until it is at least as -- large as requested. padLeft :: Int -> Char -> String -> String padLeft n c str = go n str where -- If the string is already long enough, stop traversing it. go 0 _ = str go k [] = replicate k c ++ str go k (_:xs) = go (k-1) xs genHtmlFromMod :: String -> Flags -> TixModule -> Bool -> Bool -> IO (String, [Char], ModuleSummary) genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do let theHsPath = srcDirs flags let modName0 = tixModuleName tix (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix) let arr_tix :: Array Int Integer arr_tix = listArray (0,length (tixModuleTixs tix) - 1) $ tixModuleTixs tix let tickedWith :: Int -> Integer tickedWith n = arr_tix ! n isTicked n = tickedWith n /= 0 let info = [ (pos,theMarkup) | (gid,(pos,boxLabel)) <- zip [0 ..] mix' , let binBox = case (isTicked gid,isTicked (gid+1)) of (False,False) -> [] (True,False) -> [TickedOnlyTrue] (False,True) -> [TickedOnlyFalse] (True,True) -> [] , let tickBox = if isTicked gid then [IsTicked] else [NotTicked] , theMarkup <- case boxLabel of ExpBox {} -> tickBox TopLevelBox {} -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox LocalBox {} -> tickBox BinBox _ True -> binBox _ -> [] ] let modSummary = foldr (.) id [ \ st -> case boxLabel of ExpBox False -> st { expTicked = ticked (expTicked st) , expTotal = succ (expTotal st) } ExpBox True -> st { expTicked = ticked (expTicked st) , expTotal = succ (expTotal st) , altTicked = ticked (altTicked st) , altTotal = succ (altTotal st) } TopLevelBox _ -> st { topFunTicked = ticked (topFunTicked st) , topFunTotal = succ (topFunTotal st) } _ -> st | (gid,(_pos,boxLabel)) <- zip [0 ..] mix' , let ticked = if isTicked gid then succ else id ] $ mempty -- add prefix to modName argument content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath let content' = markup tabStop info content let addLine n xs = "" ++ padLeft 5 ' ' (show n) ++ " " ++ xs let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines let fileName = modName0 ++ ".hs.html" putStrLn $ "Writing: " ++ fileName writeFileUsing (dest_dir ++ "/" ++ fileName) $ unlines ["", "", charEncodingTag, "", "", "", "

"] ++ addLines content' ++ "\n

\n\n\n"; modSummary `seq` return (modName0,fileName,modSummary) data Loc = Loc !Int !Int deriving (Eq,Ord,Show) data Markup = NotTicked | TickedOnlyTrue | TickedOnlyFalse | IsTicked | TopLevelDecl Bool -- display entry totals Integer deriving (Eq,Show) markup :: Int -- ^tabStop -> [(HpcPos,Markup)] -- random list of tick location pairs -> String -- text to mark up -> String markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs where tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark) | (pos,mark) <- mix , let (ln1,c1,ln2,c2) = fromHpcPos pos ] sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) -> (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs addMarkup :: Int -- tabStop -> String -- text to mark up -> Loc -- current location -> [(Loc,Markup)] -- stack of open ticks, with closing location -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs -> String -- check the pre-condition. --addMarkup tabStop cs loc os ticks -- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os --addMarkup tabStop cs loc os@(_:_) ticks -- | trace (show (loc,os,take 10 ticks)) False = undefined -- close all open ticks, if we have reached the end addMarkup _ [] _loc os [] = concatMap (const closeTick) os addMarkup tabStop cs loc ((o,_):os) ticks | loc > o = closeTick ++ addMarkup tabStop cs loc os ticks --addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 = -- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 = case os of ((_,tik'):_) | not (allowNesting tik0 tik') -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks where addTo (t,tik) [] = [(t,tik)] addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs | otherwise = (t',tik):(t',tik'):xs addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 = -- throw away this tick, because it is from a previous place ?? addMarkup tabStop0 cs loc os ticks addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks | ln == ln2 && col < col2 = addMarkup tabStop0 (' ':'\n':cs) loc os ticks addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks = if c0=='\n' && os/=[] then concatMap (const closeTick) (downToTopLevel os) ++ c0 : "" ++ expand 1 w ++ "" ++ concatMap (openTick.snd) (reverse (downToTopLevel os)) ++ addMarkup tabStop0 cs' loc' os ticks else if c0=='\t' then expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks else escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks where (w,cs') = span (`elem` " \t") cs loc' = foldl (flip incBy) loc (c0:w) escape '>' = ">" escape '<' = "<" escape '"' = """ escape '&' = "&" escape c = [c] expand :: Int -> String -> String expand _ "" = "" expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s where c' = tabStopAfter 8 c expand c (' ':s) = ' ' : expand (c+1) s expand _ _ = error "bad character in string for expansion" incBy :: Char -> Loc -> Loc incBy '\n' (Loc ln _c) = Loc (succ ln) 1 incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c) incBy _ (Loc ln c) = Loc ln (succ c) tabStopAfter :: Int -> Int -> Int tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..]) addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks) openTick :: Markup -> String openTick NotTicked = "" openTick IsTicked = "" openTick TickedOnlyTrue = "" openTick TickedOnlyFalse = "" openTick (TopLevelDecl False _) = openTopDecl openTick (TopLevelDecl True 0) = "-- never entered" ++ openTopDecl openTick (TopLevelDecl True 1) = "-- entered once" ++ openTopDecl openTick (TopLevelDecl True n0) = "-- entered " ++ showBigNum n0 ++ " times" ++ openTopDecl where showBigNum n | n <= 9999 = show n | otherwise = case n `quotRem` 1000 of (q, r) -> showBigNum' q ++ "," ++ showWith r showBigNum' n | n <= 999 = show n | otherwise = case n `quotRem` 1000 of (q, r) -> showBigNum' q ++ "," ++ showWith r showWith n = padLeft 3 '0' $ show n closeTick :: String closeTick = "" openTopDecl :: String openTopDecl = "" downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)] downToTopLevel ((_,TopLevelDecl {}):_) = [] downToTopLevel (o : os) = o : downToTopLevel os downToTopLevel [] = [] -- build in logic for nesting bin boxes allowNesting :: Markup -- innermost -> Markup -- outermost -> Bool allowNesting n m | n == m = False -- no need to double nest allowNesting IsTicked TickedOnlyFalse = False allowNesting IsTicked TickedOnlyTrue = False allowNesting _ _ = True ------------------------------------------------------------------------------ data ModuleSummary = ModuleSummary { expTicked :: !Int , expTotal :: !Int , topFunTicked :: !Int , topFunTotal :: !Int , altTicked :: !Int , altTotal :: !Int } deriving (Show) showModuleSummary :: (String, String, ModuleSummary) -> String showModuleSummary (modName,fileName,modSummary) = "\n" ++ " module " ++ modName ++ "\n" ++ showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ showSummary (altTicked modSummary) (altTotal modSummary) ++ showSummary (expTicked modSummary) (expTotal modSummary) ++ "\n" showTotalSummary :: ModuleSummary -> String showTotalSummary modSummary = "\n" ++ " Program Coverage Total\n" ++ showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ showSummary (altTicked modSummary) (altTotal modSummary) ++ showSummary (expTicked modSummary) (expTotal modSummary) ++ "\n" showSummary :: (Integral t, Show t) => t -> t -> String showSummary ticked total = "" ++ showP (percent ticked total) ++ "" ++ "" ++ show ticked ++ "/" ++ show total ++ "" ++ "" ++ (case percent ticked total of Nothing -> " " Just w -> bar w "bar" ) ++ "" where showP Nothing = "- " showP (Just x) = show x ++ "%" bar 0 _ = bar 100 "invbar" bar w inner = "" ++ "

" ++ "" ++ "

" percent :: (Integral a) => a -> a -> Maybe a percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total) instance Monoid ModuleSummary where mempty = ModuleSummary { expTicked = 0 , expTotal = 0 , topFunTicked = 0 , topFunTotal = 0 , altTicked = 0 , altTotal = 0 } mappend (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1) (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2) = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2) ------------------------------------------------------------------------------ writeFileUsing :: String -> String -> IO () writeFileUsing filename text = do let dest_dir = dropWhileEndLE (\ x -> x /= '/') $ filename -- We need to check for the dest_dir each time, because we use sub-dirs for -- packages, and a single .tix file might contain information about -- many package. -- create the dest_dir if needed when (not (null dest_dir)) $ createDirectoryIfMissing True dest_dir writeFile filename text ------------------------------------------------------------------------------ -- global color pallete red,green,yellow :: String red = "#f20913" green = "#60de51" yellow = "yellow"