From eb546347e5eace34612005c151121fcd1f32b257 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Thu, 21 Aug 2008 15:39:14 +0000 Subject: [PATCH] Make some utils -Wall clean --- utils/ghc-pkg/Main.hs | 19 +++++++----- utils/hpc/Hpc.hs | 22 +++++++++----- utils/hpc/HpcCombine.hs | 15 ++++++---- utils/hpc/HpcDraft.hs | 32 +++++++++++--------- utils/hpc/HpcFlags.hs | 20 +++++++++---- utils/hpc/HpcLexer.hs | 9 ++++-- utils/hpc/HpcMap.hs | 1 + utils/hpc/HpcMarkup.hs | 50 +++++++++++++++++--------------- utils/hpc/HpcOverlay.hs | 30 ++++++++++--------- utils/hpc/HpcReport.hs | 19 +++++++----- utils/hpc/HpcShowTix.hs | 13 +++++---- utils/hpc/HpcUtils.hs | 7 ++--- utils/installPackage/installPackage.hs | 4 +-- 13 files changed, 142 insertions(+), 99 deletions(-) diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index e204dbc..4294ff7 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -54,7 +54,7 @@ import GHC.ConsoleHandler import System.Posix #endif -import IO ( isPermissionError, isDoesNotExistError ) +import IO ( isPermissionError ) #if defined(GLOB) import System.Process(runInteractiveCommand) @@ -409,7 +409,7 @@ getPkgDatabases modify my_flags = do user_conf = dir subdir "package.conf" user_exists <- doesFileExist user_conf return (Just (user_conf,user_exists)) - Left ex -> + Left _ -> return Nothing -- If the user database doesn't exist, and this command isn't a @@ -434,7 +434,7 @@ getPkgDatabases modify my_flags = do let db_flags = [ f | Just f <- map is_db_flag my_flags ] where is_db_flag FlagUser - | Just (user_conf,user_exists) <- mb_user_conf + | Just (user_conf, _user_exists) <- mb_user_conf = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf is_db_flag (FlagConfig f) = Just f @@ -550,7 +550,7 @@ modifyPackage -> Force -> IO () modifyPackage fn pkgid my_flags force = do - (db_stack, Just to_modify) <- getPkgDatabases True{-modify-} my_flags + (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) -- let ((db_name, pkgs) : rest_of_stack) = db_stack -- ps <- findPackages [(db_name,pkgs)] (Id pkgid) @@ -563,7 +563,8 @@ modifyPackage fn pkgid my_flags force = do let old_broken = brokenPackages (allPackagesInStack db_stack) - rest_of_stack = [ (nm,pkgs) | (nm,pkgs) <- db_stack, nm /= db_name ] + rest_of_stack = [ (nm, mypkgs) + | (nm, mypkgs) <- db_stack, nm /= db_name ] new_stack = (db_name,new_config) : rest_of_stack new_broken = map package (brokenPackages (allPackagesInStack new_stack)) newly_broken = filter (`notElem` map package old_broken) new_broken @@ -666,7 +667,7 @@ findPackagesByDB :: PackageDBStack -> PackageArg -> IO [(NamedPackageDB, [InstalledPackageInfo])] findPackagesByDB db_stack pkgarg = case [ (db, matched) - | db@(db_name,pkgs) <- db_stack, + | db@(_, pkgs) <- db_stack, let matched = filter (pkgarg `matchesPkg`) pkgs, not (null matched) ] of [] -> die ("cannot find package " ++ pkg_msg pkgarg) @@ -783,8 +784,8 @@ brokenPackages pkgs = go [] pkgs where go avail not_avail = case partition (depsAvailable avail) not_avail of - ([], not_avail) -> not_avail - (new_avail, not_avail) -> go (new_avail ++ avail) not_avail + ([], not_avail') -> not_avail' + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo -> Bool @@ -1141,12 +1142,14 @@ catchIO io handler = io `Exception.catch` handler' handler' e = Exception.throw e #endif +#if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a #if __GLASGOW_HASKELL__ >= 609 throwIOIO = Exception.throwIO #else throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) #endif +#endif catchError :: IO a -> (String -> IO a) -> IO a #if __GLASGOW_HASKELL__ >= 609 diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs index 68fe87f..da859d0 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 = "[]" , 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 3c0ac0d..57c698a 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] .. [ [ ..]]" , 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] .. " , 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] .. " , 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 36e7a60..791537b 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] .. " , 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 b445367..30cc401 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 3d1a640..db886a3 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 b1a0f2f..873fc50 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 a40c297..f78a4af 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] .. [ [ ..]]" , 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") $ "" ++ "", "
"] ++ addLines content' ++ "\n
\n\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) = "\n" ++ "  module " ++ modName ++ "\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) ++ "\n" showTotalSummary :: ModuleSummary -> String -showTotalSummary summary = +showTotalSummary modSummary = "\n" ++ "  Program Coverage Total\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) ++ "\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 = "" ++ "
" ++ "" ++ diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs index 76cc76e..e415578 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] .. [ [...]]" , 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 98e4181..f44f967 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 $ " " @@ -201,6 +200,7 @@ modDecList hpcflags mi0 = showDecPath dp = putStrLn (" "++ concat (intersperse "." dp)) +report_plugin :: Plugin report_plugin = Plugin { name = "report" , usage = "[OPTION] .. [ [ ..]]" , 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 0d17668..efeb19e 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] .. [ [ ..]]" , 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 ed8be63..0f56629 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 diff --git a/utils/installPackage/installPackage.hs b/utils/installPackage/installPackage.hs index f36fd23..2c3d245 100644 --- a/utils/installPackage/installPackage.hs +++ b/utils/installPackage/installPackage.hs @@ -39,11 +39,11 @@ parseArgs :: [String] Bool, -- enable shell wrappers? Bool) -- strip exe? parseArgs = f normal defaultDistPref False True - where f v dp esw strip (('-':'v':val):args) + where f _ dp esw strip (('-':'v':val):args) = f (readEOrFail flagToVerbosity val) dp esw strip args f v _ esw strip ("--distpref":dp:args) = f v dp esw strip args f v dp _ strip ("--enable-shell-wrappers":args) = f v dp True strip args - f v dp esw strip ("--disable-executable-stripping":args) = f v dp esw False args + f v dp esw _ ("--disable-executable-stripping":args) = f v dp esw False args f v dp esw strip [] = (v, dp, esw, strip) f _ _ _ _ args = error ("Bad arguments: " ++ show args) -- 1.7.10.4