diff options
Diffstat (limited to 'utils/hpc')
| -rw-r--r-- | utils/hpc/Hpc.hs | 22 | ||||
| -rw-r--r-- | utils/hpc/HpcCombine.hs | 15 | ||||
| -rw-r--r-- | utils/hpc/HpcDraft.hs | 32 | ||||
| -rw-r--r-- | utils/hpc/HpcFlags.hs | 20 | ||||
| -rw-r--r-- | utils/hpc/HpcLexer.hs | 9 | ||||
| -rw-r--r-- | utils/hpc/HpcMap.hs | 1 | ||||
| -rw-r--r-- | utils/hpc/HpcMarkup.hs | 50 | ||||
| -rw-r--r-- | utils/hpc/HpcOverlay.hs | 30 | ||||
| -rw-r--r-- | utils/hpc/HpcReport.hs | 19 | ||||
| -rw-r--r-- | utils/hpc/HpcShowTix.hs | 13 | ||||
| -rw-r--r-- | utils/hpc/HpcUtils.hs | 7 |
11 files changed, 129 insertions, 89 deletions
diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs index 68fe87f98b..da859d0345 100644 --- a/utils/hpc/Hpc.hs +++ b/utils/hpc/Hpc.hs @@ -1,7 +1,6 @@ -- (c) 2007 Andy Gill -- Main driver for Hpc -import Trace.Hpc.Tix import HpcFlags import System.Environment import System.Exit @@ -36,7 +35,7 @@ helpList = ] section :: String -> [String] -> String -section msg [] = "" +section _ [] = "" section msg cmds = msg ++ ":\n" ++ unlines [ take 14 (" " ++ cmd ++ repeat ' ') ++ summary hook | cmd <- cmds @@ -48,10 +47,10 @@ dispatch :: [String] -> IO () dispatch [] = do helpList exitWith ExitSuccess -dispatch (txt:args) = do +dispatch (txt:args0) = do case lookup txt hooks' of - Just plugin -> parse plugin args - _ -> parse help_plugin (txt:args) + Just plugin -> parse plugin args0 + _ -> parse help_plugin (txt:args0) where parse plugin args = case getOpt Permute (options plugin []) args of @@ -68,12 +67,15 @@ dispatch (txt:args) = do $ foldr (.) id o $ init_flags plugin implementation plugin flags ns + +main :: IO () main = do args <- getArgs dispatch args ------------------------------------------------------------------------------ +hooks :: [Plugin] hooks = [ help_plugin , report_plugin , markup_plugin @@ -86,10 +88,12 @@ hooks = [ help_plugin , version_plugin ] +hooks' :: [(String, Plugin)] hooks' = [ (name hook,hook) | hook <- hooks ] ------------------------------------------------------------------------------ +help_plugin :: Plugin help_plugin = Plugin { name = "help" , usage = "[<HPC_COMMAND>]" , summary = "Display help for hpc or a single command" @@ -99,10 +103,11 @@ help_plugin = Plugin { name = "help" , final_flags = default_final_flags } -help_main flags [] = do +help_main :: Flags -> [String] -> IO () +help_main _ [] = do helpList exitWith ExitSuccess -help_main flags (sub_txt:_) = do +help_main _ (sub_txt:_) = do case lookup sub_txt hooks' of Nothing -> do putStrLn $ "no such hpc command : " ++ sub_txt @@ -111,10 +116,12 @@ help_main flags (sub_txt:_) = do command_usage plugin' exitWith ExitSuccess +help_options :: FlagOptSeq help_options = id ------------------------------------------------------------------------------ +version_plugin :: Plugin version_plugin = Plugin { name = "version" , usage = "" , summary = "Display version for hpc" @@ -124,6 +131,7 @@ version_plugin = Plugin { name = "version" , final_flags = default_final_flags } +version_main :: Flags -> [String] -> IO () version_main _ _ = putStrLn $ "hpc tools, version 0.6" diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs index 3c0ac0d22e..57c698a8ca 100644 --- a/utils/hpc/HpcCombine.hs +++ b/utils/hpc/HpcCombine.hs @@ -13,15 +13,16 @@ import HpcFlags import Control.Monad import qualified HpcSet as Set import qualified HpcMap as Map -import System.Environment ------------------------------------------------------------------------------ +sum_options :: FlagOptSeq sum_options = excludeOpt . includeOpt . outputOpt . unionModuleOpt +sum_plugin :: Plugin sum_plugin = Plugin { name = "sum" , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]" , options = sum_options @@ -31,6 +32,7 @@ sum_plugin = Plugin { name = "sum" , final_flags = default_final_flags } +combine_options :: FlagOptSeq combine_options = excludeOpt . includeOpt @@ -39,6 +41,7 @@ combine_options . combineFunOptInfo . unionModuleOpt +combine_plugin :: Plugin combine_plugin = Plugin { name = "combine" , usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>" , options = combine_options @@ -48,6 +51,7 @@ combine_plugin = Plugin { name = "combine" , final_flags = default_final_flags } +map_options :: FlagOptSeq map_options = excludeOpt . includeOpt @@ -56,6 +60,7 @@ map_options . mapFunOptInfo . unionModuleOpt +map_plugin :: Plugin map_plugin = Plugin { name = "map" , usage = "[OPTION] .. <TIX_FILE> " , options = map_options @@ -68,7 +73,7 @@ map_plugin = Plugin { name = "map" ------------------------------------------------------------------------------ sum_main :: Flags -> [String] -> IO () -sum_main flags [] = hpcError sum_plugin $ "no .tix file specified" +sum_main _ [] = hpcError sum_plugin $ "no .tix file specified" sum_main flags (first_file:more_files) = do Just tix <- readTix first_file @@ -95,7 +100,7 @@ combine_main flags [first_file,second_file] = do case outputFile flags of "-" -> putStrLn (show tix) out -> writeTix out tix -combine_main flags [] = hpcError combine_plugin $ "need exactly two .tix files to combine" +combine_main _ _ = hpcError combine_plugin $ "need exactly two .tix files to combine" map_main :: Flags -> [String] -> IO () map_main flags [first_file] = do @@ -111,8 +116,8 @@ map_main flags [first_file] = do case outputFile flags of "-" -> putStrLn (show tix') out -> writeTix out tix' -map_main flags [] = hpcError map_plugin $ "no .tix file specified" -map_main flags _ = hpcError map_plugin $ "to many .tix files specified" +map_main _ [] = hpcError map_plugin $ "no .tix file specified" +map_main _ _ = hpcError map_plugin $ "to many .tix files specified" mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix mergeTixFile flags fn tix file_name = do diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs index 36e7a60de4..791537b47c 100644 --- a/utils/hpc/HpcDraft.hs +++ b/utils/hpc/HpcDraft.hs @@ -9,11 +9,11 @@ import HpcFlags import Control.Monad import qualified HpcSet as Set import qualified HpcMap as Map -import System.Environment import HpcUtils import Data.Tree ------------------------------------------------------------------------------ +draft_options :: FlagOptSeq draft_options = excludeOpt . includeOpt @@ -21,6 +21,7 @@ draft_options . hpcDirOpt . outputOpt +draft_plugin :: Plugin draft_plugin = Plugin { name = "draft" , usage = "[OPTION] .. <TIX_FILE>" , options = draft_options @@ -33,6 +34,7 @@ draft_plugin = Plugin { name = "draft" ------------------------------------------------------------------------------ draft_main :: Flags -> [String] -> IO () +draft_main _ [] = error "draft_main: unhandled case: []" draft_main hpcflags (progName:mods) = do let hpcflags1 = hpcflags { includeMods = Set.fromList mods @@ -55,15 +57,14 @@ draft_main hpcflags (progName:mods) = do makeDraft :: Flags -> TixModule -> IO String makeDraft hpcflags tix = do - let mod = tixModuleName tix - hash = tixModuleHash tix + let modu = tixModuleName tix tixs = tixModuleTixs tix - mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags (Right tix) + (Mix filepath _ _ _ entries) <- readMixWithFlags hpcflags (Right tix) let forest = createMixEntryDom - [ (span,(box,v > 0)) - | ((span,box),v) <- zip entries tixs + [ (srcspan,(box,v > 0)) + | ((srcspan,box),v) <- zip entries tixs ] -- let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span) @@ -95,22 +96,25 @@ makeDraft hpcflags tix = do where txt = grabHpcPos hsMap pos - showPleaseTick d (TickInside [str] pos pleases) = + showPleaseTick d (TickInside [str] _ pleases) = spaces d ++ "inside \"" ++ str ++ "\" {\n" ++ showPleaseTicks (d + 2) pleases ++ spaces d ++ "}" + showPleaseTick _ (TickInside _ _ _) + = error "showPleaseTick: Unhandled case TickInside" + showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases) spaces d = take d (repeat ' ') - return $ "module " ++ show (fixPackageSuffix mod) ++ " {\n" ++ + return $ "module " ++ show (fixPackageSuffix modu) ++ " {\n" ++ showPleaseTicks 2 non_ticked ++ "}" fixPackageSuffix :: String -> String -fixPackageSuffix mod = case span (/= '/') mod of - (before,'/':after) -> before ++ ":" ++ after - _ -> mod +fixPackageSuffix modu = case span (/= '/') modu of + (before,'/':after) -> before ++ ":" ++ after + _ -> modu data PleaseTick = TickFun [String] HpcPos @@ -118,6 +122,8 @@ data PleaseTick | TickInside [String] HpcPos [PleaseTick] deriving Show +mkTickInside :: [String] -> HpcPos -> [PleaseTick] + -> [PleaseTick] -> [PleaseTick] mkTickInside _ _ [] = id mkTickInside nm pos inside = (TickInside nm pos inside :) @@ -127,11 +133,11 @@ findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _) = [ TickFun nm pos ] findNotTickedFromTree (Node (pos,(LocalBox nm,False):_) _) = [ TickFun nm pos ] -findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):others) children) +findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):_) children) = mkTickInside nm pos (findNotTickedFromList children) [] findNotTickedFromTree (Node (pos,_:others) children) = findNotTickedFromTree (Node (pos,others) children) -findNotTickedFromTree (Node (pos,[]) children) = findNotTickedFromList children +findNotTickedFromTree (Node (_, []) children) = findNotTickedFromList children findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick] findNotTickedFromList = concatMap findNotTickedFromTree diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs index b445367023..30cc40175c 100644 --- a/utils/hpc/HpcFlags.hs +++ b/utils/hpc/HpcFlags.hs @@ -3,7 +3,6 @@ module HpcFlags where import System.Console.GetOpt -import Data.Maybe ( fromMaybe ) import qualified HpcSet as Set import Data.Char import Trace.Hpc.Tix @@ -30,6 +29,7 @@ data Flags = Flags , mergeModule :: MergeFun -- module-wise merge } +default_flags :: Flags default_flags = Flags { outputFile = "-" , includeMods = Set.empty @@ -54,6 +54,7 @@ default_flags = Flags -- We do this after reading flags, because the defaults -- depends on if specific flags we used. +default_final_flags :: Flags -> Flags default_final_flags flags = flags { srcDirs = if null (srcDirs flags) then ["."] @@ -71,6 +72,10 @@ anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail infoArg :: String -> FlagOptSeq infoArg info = (:) $ Option [] [] (NoArg $ id) info +excludeOpt, includeOpt, hpcDirOpt, srcDirOpt, destDirOpt, outputOpt, + perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt, + altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt, + mapFunOptInfo, unionModuleOpt :: FlagOptSeq excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f } @@ -125,12 +130,13 @@ unionModuleOpt = noArg "union" ------------------------------------------------------------------------------- readMixWithFlags :: Flags -> Either String TixModule -> IO Mix -readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags - | dir <- srcDirs flags - ] mod +readMixWithFlags flags modu = readMix [ dir ++ "/" ++ hpcDir flags + | dir <- srcDirs flags + ] modu ------------------------------------------------------------------------------- +command_usage :: Plugin -> IO () command_usage plugin = putStrLn $ "Usage: hpc " ++ (name plugin) ++ " " ++ @@ -213,9 +219,10 @@ data PostFun = ID | INV | ZERO thePostFun :: PostFun -> Integer -> Integer thePostFun ID x = x thePostFun INV 0 = 1 -thePostFun INV n = 0 -thePostFun ZERO x = 0 +thePostFun INV _ = 0 +thePostFun ZERO _ = 0 +postFuns :: [(String, PostFun)] postFuns = [ (show pos,pos) | pos <- [ID .. ZERO] ] @@ -228,6 +235,7 @@ theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a theMergeFun INTERSECTION = Set.intersection theMergeFun UNION = Set.union +mergeFuns :: [(String, MergeFun)] mergeFuns = [ (show pos,pos) | pos <- [INTERSECTION,UNION] ] diff --git a/utils/hpc/HpcLexer.hs b/utils/hpc/HpcLexer.hs index 3d1a640b3c..db886a38ac 100644 --- a/utils/hpc/HpcLexer.hs +++ b/utils/hpc/HpcLexer.hs @@ -24,28 +24,33 @@ lexer (c:cs) line column | isAlpha c = lexerKW cs [c] line (succ column) | isDigit c = lexerINT cs [c] line (succ column) | otherwise = error "lexer failure" -lexer [] line colunm = [] +lexer [] _ _ = [] +lexerKW :: String -> String -> Int -> Int -> [(Int,Int,Token)] lexerKW (c:cs) s line column | isAlpha c = lexerKW cs (s ++ [c]) line (succ column) lexerKW other s line column = (line,column,ID s) : lexer other line column +lexerINT :: String -> String -> Int -> Int -> [(Int,Int,Token)] lexerINT (c:cs) s line column | isDigit c = lexerINT cs (s ++ [c]) line (succ column) lexerINT other s line column = (line,column,INT (read s)) : lexer other line column -- not technically correct for the new column count, but a good approximation. +lexerSTR :: String -> Int -> Int -> [(Int,Int,Token)] lexerSTR cs line column = case lex ('"' : cs) of [(str,rest)] -> (line,succ column,STR (read str)) : lexer rest line (length (show str) + column + 1) _ -> error "bad string" +lexerCAT :: String -> String -> Int -> Int -> [(Int,Int,Token)] lexerCAT (c:cs) s line column | c == ']' = (line,column,CAT s) : lexer cs line (succ column) | otherwise = lexerCAT cs (s ++ [c]) line (succ column) -lexerCAT other s line column = error "lexer failure in CAT" +lexerCAT [] _ _ _ = error "lexer failure in CAT" +test :: IO () test = do t <- readFile "EXAMPLE.tc" print (initLexer t) diff --git a/utils/hpc/HpcMap.hs b/utils/hpc/HpcMap.hs index b1a0f2f781..873fc5073b 100644 --- a/utils/hpc/HpcMap.hs +++ b/utils/hpc/HpcMap.hs @@ -10,6 +10,7 @@ import qualified Data.Map as Map lookup :: Ord key => key -> Map key elt -> Maybe elt fromList :: Ord key => [(key,elt)] -> Map key elt fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a +toList :: Ord key => Map key elt -> [(key,elt)] #if __GLASGOW_HASKELL__ < 604 type Map key elt = Map.FiniteMap key elt diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index a40c297d4f..f78a4af220 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -12,7 +12,6 @@ import Trace.Hpc.Util import HpcFlags import HpcUtils -import System.Environment import System.Directory import Data.List import Data.Maybe(fromJust) @@ -22,6 +21,7 @@ import qualified HpcSet as Set ------------------------------------------------------------------------------ +markup_options :: FlagOptSeq markup_options = excludeOpt . includeOpt @@ -30,7 +30,8 @@ markup_options . funTotalsOpt . altHighlightOpt . destDirOpt - + +markup_plugin :: Plugin markup_plugin = Plugin { name = "markup" , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" , options = markup_options @@ -75,14 +76,14 @@ markup_main flags (prog:modNames) = do index_alt = "hpc_index_alt" index_exp = "hpc_index_exp" - let writeSummary name cmp = do + let writeSummary filename cmp = do let mods' = sortBy cmp mods - putStrLn $ "Writing: " ++ (name ++ ".html") - writeFile (dest_dir ++ "/" ++ name ++ ".html") $ + putStrLn $ "Writing: " ++ (filename ++ ".html") + writeFile (dest_dir ++ "/" ++ filename ++ ".html") $ "<html>" ++ "<style type=\"text/css\">" ++ "table.bar { background-color: #f25913; }\n" ++ @@ -107,13 +108,13 @@ markup_main flags (prog:modNames) = do "<th>%</th>" ++ "<th colspan=2>covered / total</th>" ++ "</tr>" ++ - concat [ showModuleSummary (modName,fileName,summary) - | (modName,fileName,summary) <- mods' + concat [ showModuleSummary (modName,fileName,modSummary) + | (modName,fileName,modSummary) <- mods' ] ++ "<tr></tr>" ++ showTotalSummary (mconcat - [ summary - | (_,_,summary) <- mods' + [ modSummary + | (_,_,modSummary) <- mods' ]) ++ "</table></html>\n" @@ -132,7 +133,8 @@ markup_main flags (prog:modNames) = do (percent (expTicked s1) (expTotal s1)) -markup_main flags [] = hpcError markup_plugin $ "no .tix file or executable name specified" +markup_main _ [] + = hpcError markup_plugin $ "no .tix file or executable name specified" genHtmlFromMod :: String @@ -145,7 +147,7 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do let theHsPath = srcDirs flags let modName0 = tixModuleName tix - (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags (Right tix) + (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix) let arr_tix :: Array Int Integer arr_tix = listArray (0,length (tixModuleTixs tix) - 1) @@ -176,7 +178,7 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do ] - let summary = foldr (.) id + let modSummary = foldr (.) id [ \ st -> case boxLabel of ExpBox False @@ -228,7 +230,7 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do "</style>", "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n"; - summary `seq` return (modName0,fileName,summary) + modSummary `seq` return (modName0,fileName,modSummary) data Loc = Loc !Int !Int deriving (Eq,Ord,Show) @@ -288,8 +290,8 @@ addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 = where addTo (t,tik) [] = [(t,tik)] - addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs - | t > t' = (t',tik):(t',tik'):xs + 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 ?? @@ -392,22 +394,22 @@ data ModuleSummary = ModuleSummary showModuleSummary :: (String, String, ModuleSummary) -> String -showModuleSummary (modName,fileName,summary) = +showModuleSummary (modName,fileName,modSummary) = "<tr>\n" ++ "<td> <tt>module <a href=\"" ++ fileName ++ "\">" ++ modName ++ "</a></tt></td>\n" ++ - showSummary (topFunTicked summary) (topFunTotal summary) ++ - showSummary (altTicked summary) (altTotal summary) ++ - showSummary (expTicked summary) (expTotal summary) ++ + showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ + showSummary (altTicked modSummary) (altTotal modSummary) ++ + showSummary (expTicked modSummary) (expTotal modSummary) ++ "</tr>\n" showTotalSummary :: ModuleSummary -> String -showTotalSummary summary = +showTotalSummary modSummary = "<tr style=\"background: #e0e0e0\">\n" ++ "<th align=left> Program Coverage Total</tt></th>\n" ++ - showSummary (topFunTicked summary) (topFunTotal summary) ++ - showSummary (altTicked summary) (altTotal summary) ++ - showSummary (expTicked summary) (expTotal summary) ++ + showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ + showSummary (altTicked modSummary) (altTotal modSummary) ++ + showSummary (expTicked modSummary) (expTotal modSummary) ++ "</tr>\n" showSummary :: (Integral t) => t -> t -> String @@ -422,7 +424,7 @@ showSummary ticked total = where showP Nothing = "- " showP (Just x) = show x ++ "%" - bar 0 inner = bar 100 "invbar" + bar 0 _ = bar 100 "invbar" bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++ "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++ "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++ diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs index 76cc76e0d7..e415578c07 100644 --- a/utils/hpc/HpcOverlay.hs +++ b/utils/hpc/HpcOverlay.hs @@ -9,11 +9,13 @@ import Trace.Hpc.Util import HpcMap as Map import Data.Tree +overlay_options :: FlagOptSeq overlay_options = srcDirOpt . hpcDirOpt . outputOpt +overlay_plugin :: Plugin overlay_plugin = Plugin { name = "overlay" , usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]" , options = overlay_options @@ -23,19 +25,19 @@ overlay_plugin = Plugin { name = "overlay" , final_flags = default_final_flags } - -overlay_main flags [] = hpcError overlay_plugin $ "no overlay file specified" +overlay_main :: Flags -> [String] -> IO () +overlay_main _ [] = hpcError overlay_plugin $ "no overlay file specified" overlay_main flags files = do specs <- mapM hpcParser files - let spec@(Spec globals modules) = concatSpec specs + let (Spec globals modules) = concatSpec specs let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ] mod_info <- - sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left mod) + sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu) content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags) - processModule mod content mix mod_spec globals - | (mod,mod_spec) <- Map.toList modules1 + processModule modu content mix mod_spec globals + | (modu, mod_spec) <- Map.toList modules1 ] @@ -52,7 +54,7 @@ processModule :: String -- ^ module name -> [Tick] -- ^ local ticks -> [ExprTick] -- ^ global ticks -> IO TixModule -processModule modName modContents (Mix filepath timestamp hash tabstop entries) locals globals = do +processModule modName modContents (Mix _ _ hash _ entries) locals globals = do let hsMap :: Map.Map Int String hsMap = Map.fromList (zip [1..] $ lines modContents) @@ -71,7 +73,7 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries) -- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool - plzTick pos (ExpBox _) (TickExpression _ match q g) = + plzTick pos (ExpBox _) (TickExpression _ match q _) = qualifier pos q && case match of Nothing -> True @@ -81,7 +83,7 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries) plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool plzTopTick pos label (ExprTick ignore) = plzTick pos label ignore - plzTopTick pos _ (TickFunction fn q g) = + plzTopTick pos _ (TickFunction fn q _) = qualifier pos q && pos `inside` fn plzTopTick pos label (InsideFunction fn igs) = pos `inside` fn && any (plzTopTick pos label) igs @@ -95,11 +97,11 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries) ] - let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span) + -- let show' (srcspan,stuff) = show (srcspan,stuff,grabHpcPos hsMap span) let forest = createMixEntryDom - [ (span,ix) - | ((span,_),ix) <- zip entries [0..] + [ (srcspan,ix) + | ((srcspan,_),ix) <- zip entries [0..] ] @@ -131,9 +133,9 @@ processModule modName modContents (Mix filepath timestamp hash tabstop entries) return $ TixModule modName hash (length tixs') tixs' qualifier :: HpcPos -> Maybe Qualifier -> Bool -qualifier pos Nothing = True +qualifier _ Nothing = True qualifier pos (Just (OnLine n)) = n == l1 && n == l2 - where (l1,c1,l2,c2) = fromHpcPos pos + where (l1,_,l2,_) = fromHpcPos pos qualifier pos (Just (AtPosition l1' c1' l2' c2')) = (l1', c1', l2', c2') == fromHpcPos pos diff --git a/utils/hpc/HpcReport.hs b/utils/hpc/HpcReport.hs index 98e418172b..f44f967eaa 100644 --- a/utils/hpc/HpcReport.hs +++ b/utils/hpc/HpcReport.hs @@ -5,9 +5,7 @@ module HpcReport (report_plugin) where -import System.Exit import Prelude hiding (exp) -import System(getArgs) import List(sort,intersperse,sortBy) import HpcFlags import Trace.Hpc.Mix @@ -104,8 +102,8 @@ allBinCounts mi = accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo accumCounts [] mi = mi -accumCounts ((bl,btc):etc) mi | single bl = - accumCounts etc mi' +accumCounts ((bl,btc):etc) mi + | single bl = accumCounts etc mi' where mi' = case bl of ExpBox False -> mi{exp = inc (exp mi)} @@ -120,6 +118,7 @@ accumCounts ((bl,btc):etc) mi | single bl = , tixCount = tc + bit (btc>0) } upd dp dps = if btc>0 then dps else dp:dps +accumCounts [_] _ = error "accumCounts: Unhandled case: [_] _" accumCounts ((bl0,btc0):(bl1,btc1):etc) mi = accumCounts etc mi' where @@ -159,7 +158,7 @@ modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do else mi modReport :: Flags -> TixModule -> IO () -modReport hpcflags tix@(TixModule moduleName _ _ tickCounts) = do +modReport hpcflags tix@(TixModule moduleName _ _ _) = do mi <- modInfo hpcflags False tix if xmlOutput hpcflags then putStrLn $ " <module name = " ++ show moduleName ++ ">" @@ -201,6 +200,7 @@ modDecList hpcflags mi0 = showDecPath dp = putStrLn (" "++ concat (intersperse "." dp)) +report_plugin :: Plugin report_plugin = Plugin { name = "report" , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" , options = report_options @@ -222,12 +222,12 @@ report_main hpcflags (progName:mods) = do Just (Tix tickCounts) -> makeReport hpcflags1 progName $ sortBy (\ mod1 mod2 -> tixModuleName mod1 `compare` tixModuleName mod2) - $ [ tix - | tix@(TixModule m _h _ tcs) <- tickCounts + $ [ tix' + | tix'@(TixModule m _ _ _) <- tickCounts , allowModule hpcflags1 m ] Nothing -> hpcError report_plugin $ "unable to find tix file for:" ++ progName -report_main hpcflags [] = +report_main _ [] = hpcError report_plugin $ "no .tix file or executable name specified" makeReport :: Flags -> String -> [TixModule] -> IO () @@ -256,12 +256,15 @@ element tag attrs = putStrLn $ | (x,y) <- attrs ] ++ "/>" +xmlBT :: BoxTixCounts -> [(String, String)] xmlBT (BT b t) = [("boxes",show b),("count",show t)] +xmlBBT :: BinBoxTixCounts -> [(String, String)] xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))] ------------------------------------------------------------------------------ +report_options :: FlagOptSeq report_options = perModuleOpt . decListOpt diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs index 0d17668416..efeb19e275 100644 --- a/utils/hpc/HpcShowTix.hs +++ b/utils/hpc/HpcShowTix.hs @@ -2,12 +2,12 @@ module HpcShowTix (showtix_plugin) where import Trace.Hpc.Mix import Trace.Hpc.Tix -import Trace.Hpc.Util import HpcFlags import qualified HpcSet as Set +showtix_options :: FlagOptSeq showtix_options = excludeOpt . includeOpt @@ -15,6 +15,7 @@ showtix_options . hpcDirOpt . outputOpt +showtix_plugin :: Plugin showtix_plugin = Plugin { name = "show" , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" , options = showtix_options @@ -25,8 +26,8 @@ showtix_plugin = Plugin { name = "show" } - -showtix_main flags [] = hpcError showtix_plugin $ "no .tix file or executable name specified" +showtix_main :: Flags -> [String] -> IO () +showtix_main _ [] = hpcError showtix_plugin $ "no .tix file or executable name specified" showtix_main flags (prog:modNames) = do let hpcflags1 = flags { includeMods = Set.fromList modNames @@ -50,10 +51,10 @@ showtix_main flags (prog:modNames) = do sequence_ [ sequence_ [ putStrLn (rjust 5 (show ix) ++ " " ++ rjust 10 (show count) ++ " " ++ ljust 20 modName ++ " " ++ rjust 20 (show pos) ++ " " ++ show lab) - | (count,ix,(pos,lab)) <- zip3 tixs [(0::Int)..] entries + | (count,ix,(pos,lab)) <- zip3 tixs' [(0::Int)..] entries ] - | ( TixModule modName hash _ tixs - , Mix _file _timestamp _hash _tab entries + | ( TixModule modName _hash1 _ tixs' + , Mix _file _timestamp _hash2 _tab entries ) <- tixs_mixs ] diff --git a/utils/hpc/HpcUtils.hs b/utils/hpc/HpcUtils.hs index ed8be63675..0f56629782 100644 --- a/utils/hpc/HpcUtils.hs +++ b/utils/hpc/HpcUtils.hs @@ -2,18 +2,17 @@ module HpcUtils where import Trace.Hpc.Util import qualified HpcMap as Map -import HpcFlags -- turns \n into ' ' -- | grab's the text behind a HpcPos; grabHpcPos :: Map.Map Int String -> HpcPos -> String -grabHpcPos hsMap span = +grabHpcPos hsMap srcspan = case lns of [ln] -> (take ((c2 - c1) + 1) $ drop (c1 - 1) ln) _ -> let lns1 = drop (c1 -1) (head lns) : tail lns lns2 = init lns1 ++ [take (c2 + 1) (last lns1) ] in foldl1 (\ xs ys -> xs ++ "\n" ++ ys) lns2 - where (l1,c1,l2,c2) = fromHpcPos span + where (l1,c1,l2,c2) = fromHpcPos srcspan lns = map (\ n -> case Map.lookup n hsMap of Just ln -> ln Nothing -> error $ "bad line number : " ++ show n @@ -21,7 +20,7 @@ grabHpcPos hsMap span = readFileFromPath :: (String -> IO String) -> String -> [String] -> IO String -readFileFromPath err filename@('/':_) _ = readFile filename +readFileFromPath _ filename@('/':_) _ = readFile filename readFileFromPath err filename path0 = readTheFile path0 where readTheFile [] = err $ "could not find " ++ show filename |