import System.Posix
#endif
-import IO ( isPermissionError, isDoesNotExistError )
+import IO ( isPermissionError )
#if defined(GLOB)
import System.Process(runInteractiveCommand)
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
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
-> 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)
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
-> 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)
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
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
-- (c) 2007 Andy Gill
-- Main driver for Hpc
-import Trace.Hpc.Tix
import HpcFlags
import System.Environment
import System.Exit
]
section :: String -> [String] -> String
-section msg [] = ""
+section _ [] = ""
section msg cmds = msg ++ ":\n"
++ unlines [ take 14 (" " ++ cmd ++ repeat ' ') ++ summary hook
| cmd <- cmds
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
$ 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
, 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"
, 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
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"
, final_flags = default_final_flags
}
+version_main :: Flags -> [String] -> IO ()
version_main _ _ = putStrLn $ "hpc tools, version 0.6"
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
, final_flags = default_final_flags
}
+combine_options :: FlagOptSeq
combine_options
= excludeOpt
. includeOpt
. combineFunOptInfo
. unionModuleOpt
+combine_plugin :: Plugin
combine_plugin = Plugin { name = "combine"
, usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
, options = combine_options
, final_flags = default_final_flags
}
+map_options :: FlagOptSeq
map_options
= excludeOpt
. includeOpt
. mapFunOptInfo
. unionModuleOpt
+map_plugin :: Plugin
map_plugin = Plugin { name = "map"
, usage = "[OPTION] .. <TIX_FILE> "
, options = map_options
------------------------------------------------------------------------------
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
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
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
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
. hpcDirOpt
. outputOpt
+draft_plugin :: Plugin
draft_plugin = Plugin { name = "draft"
, usage = "[OPTION] .. <TIX_FILE>"
, options = draft_options
------------------------------------------------------------------------------
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
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)
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
| TickInside [String] HpcPos [PleaseTick]
deriving Show
+mkTickInside :: [String] -> HpcPos -> [PleaseTick]
+ -> [PleaseTick] -> [PleaseTick]
mkTickInside _ _ [] = id
mkTickInside nm pos inside = (TickInside nm pos inside :)
= [ 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
module HpcFlags where
import System.Console.GetOpt
-import Data.Maybe ( fromMaybe )
import qualified HpcSet as Set
import Data.Char
import Trace.Hpc.Tix
, mergeModule :: MergeFun -- module-wise merge
}
+default_flags :: Flags
default_flags = Flags
{ outputFile = "-"
, includeMods = Set.empty
-- 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 ["."]
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 }
-------------------------------------------------------------------------------
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) ++ " " ++
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]
]
theMergeFun INTERSECTION = Set.intersection
theMergeFun UNION = Set.union
+mergeFuns :: [(String, MergeFun)]
mergeFuns = [ (show pos,pos)
| pos <- [INTERSECTION,UNION]
]
| 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)
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
import HpcFlags
import HpcUtils
-import System.Environment
import System.Directory
import Data.List
import Data.Maybe(fromJust)
------------------------------------------------------------------------------
+markup_options :: FlagOptSeq
markup_options
= excludeOpt
. includeOpt
. funTotalsOpt
. altHighlightOpt
. destDirOpt
-
+
+markup_plugin :: Plugin
markup_plugin = Plugin { name = "markup"
, usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
, options = markup_options
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" ++
"<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"
(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
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)
]
- let summary = foldr (.) id
+ let modSummary = foldr (.) id
[ \ st ->
case boxLabel of
ExpBox False
"</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)
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 ??
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
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>" ++
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
, 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
]
-> [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)
-- 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
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
]
- 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..]
]
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
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
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)}
, 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
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 ++ ">"
showDecPath dp = putStrLn (" "++
concat (intersperse "." dp))
+report_plugin :: Plugin
report_plugin = Plugin { name = "report"
, usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
, options = report_options
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 ()
| (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
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
. hpcDirOpt
. outputOpt
+showtix_plugin :: Plugin
showtix_plugin = Plugin { name = "show"
, usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
, options = showtix_options
}
-
-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
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
]
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
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
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)
projects / ghc-hetmet.git / commitdiff