--------------------------------------------------------- -- 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.FilePath import System.IO (localeEncoding) import Data.List import Data.Maybe(fromJust) import Data.Semigroup as Semi 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 . verbosityOpt 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 unless (verbosity flags < Normal) $ 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" unless (verbosity flags < Normal) $ putStrLn $ "Writing: " ++ fileName writeFileUsing (dest_dir fileName) $ unlines ["", "", charEncodingTag, "", "", "", "

",
                     concat [
                         "",
                         "never executed ",
                         "always true ",
                         "always false"],
                     "

", "

"] ++ 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 Semi.Semigroup ModuleSummary where (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) instance Monoid ModuleSummary where mempty = ModuleSummary { expTicked = 0 , expTotal = 0 , topFunTicked = 0 , topFunTotal = 0 , altTicked = 0 , altTotal = 0 } mappend = (<>) ------------------------------------------------------------------------------ writeFileUsing :: String -> String -> IO () writeFileUsing filename text = do -- 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 createDirectoryIfMissing True (takeDirectory filename) writeFile filename text ------------------------------------------------------------------------------ -- global color pallete red,green,yellow :: String red = "#f20913" green = "#60de51" yellow = "yellow"