Commit 95027b82 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

de-tab hpc

parent c04a9849
......@@ -23,6 +23,7 @@ SRC_HC_OPTS += $(WERROR) -Wall
GhcStage1HcOpts += -fwarn-tabs
GhcStage2HcOpts += -fwarn-tabs
utils/hpc_dist-install_EXTRA_HC_OPTS += -fwarn-tabs
#####################
SRC_HC_OPTS += -H64m -O0
......
......@@ -3,7 +3,7 @@
-- Andy Gill, Oct 2006
---------------------------------------------------------
module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
import Trace.Hpc.Tix
import Trace.Hpc.Util
......@@ -16,70 +16,70 @@ import qualified Data.Map as Map
------------------------------------------------------------------------------
sum_options :: FlagOptSeq
sum_options
sum_options
= excludeOpt
. includeOpt
. outputOpt
. unionModuleOpt
. unionModuleOpt
sum_plugin :: Plugin
sum_plugin = Plugin { name = "sum"
, usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
, options = sum_options
, summary = "Sum multiple .tix files in a single .tix file"
, implementation = sum_main
, init_flags = default_flags
, final_flags = default_final_flags
}
, usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
, options = sum_options
, summary = "Sum multiple .tix files in a single .tix file"
, implementation = sum_main
, init_flags = default_flags
, final_flags = default_final_flags
}
combine_options :: FlagOptSeq
combine_options
combine_options
= excludeOpt
. includeOpt
. outputOpt
. combineFunOpt
. combineFunOptInfo
. unionModuleOpt
. unionModuleOpt
combine_plugin :: Plugin
combine_plugin = Plugin { name = "combine"
, usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
, options = combine_options
, summary = "Combine two .tix files in a single .tix file"
, implementation = combine_main
, init_flags = default_flags
, final_flags = default_final_flags
}
, usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
, options = combine_options
, summary = "Combine two .tix files in a single .tix file"
, implementation = combine_main
, init_flags = default_flags
, final_flags = default_final_flags
}
map_options :: FlagOptSeq
map_options
map_options
= excludeOpt
. includeOpt
. outputOpt
. mapFunOpt
. mapFunOpt
. mapFunOptInfo
. unionModuleOpt
. unionModuleOpt
map_plugin :: Plugin
map_plugin = Plugin { name = "map"
, usage = "[OPTION] .. <TIX_FILE> "
, options = map_options
, summary = "Map a function over a single .tix file"
, implementation = map_main
, init_flags = default_flags
, final_flags = default_final_flags
}
, usage = "[OPTION] .. <TIX_FILE> "
, options = map_options
, summary = "Map a function over a single .tix file"
, implementation = map_main
, init_flags = default_flags
, final_flags = default_final_flags
}
------------------------------------------------------------------------------
sum_main :: Flags -> [String] -> IO ()
sum_main _ [] = 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
tix' <- foldM (mergeTixFile flags (+))
(filterTix flags tix)
more_files
tix' <- foldM (mergeTixFile flags (+))
(filterTix flags tix)
more_files
case outputFile flags of
"-" -> putStrLn (show tix')
......@@ -92,10 +92,10 @@ combine_main flags [first_file,second_file] = do
Just tix1 <- readTix first_file
Just tix2 <- readTix second_file
let tix = mergeTix (mergeModule flags)
f
(filterTix flags tix1)
(filterTix flags tix2)
let tix = mergeTix (mergeModule flags)
f
(filterTix flags tix1)
(filterTix flags tix2)
case outputFile flags of
"-" -> putStrLn (show tix)
......@@ -110,55 +110,55 @@ map_main flags [first_file] = do
let (Tix inside_tix) = filterTix flags tix
let tix' = Tix [ TixModule m p i (map f t)
| TixModule m p i t <- inside_tix
]
| TixModule m p i t <- inside_tix
]
case outputFile flags of
"-" -> putStrLn (show tix')
out -> writeTix out tix'
map_main _ [] = hpcError map_plugin $ "no .tix file specified"
map_main _ _ = 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
Just new_tix <- readTix file_name
return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix)
-- could allow different numbering on the module info,
-- could allow different numbering on the module info,
-- as long as the total is the same; will require normalization.
mergeTix :: MergeFun
-> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
-> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
mergeTix modComb f
(Tix t1)
(Tix t2) = Tix
[ case (Map.lookup m fm1,Map.lookup m fm2) of
-- todo, revisit the semantics of this combination
(Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
| hash1 /= hash2
|| length tix1 /= length tix2
|| len1 /= length tix1
|| len2 /= length tix2
-> error $ "mismatched in module " ++ m
| otherwise ->
TixModule m hash1 len1 (zipWith f tix1 tix2)
(Just m1,Nothing) ->
m1
(Nothing,Just m2) ->
m2
_ -> error "impossible"
| m <- Set.toList (theMergeFun modComb m1s m2s)
(Tix t1)
(Tix t2) = Tix
[ case (Map.lookup m fm1,Map.lookup m fm2) of
-- todo, revisit the semantics of this combination
(Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
| hash1 /= hash2
|| length tix1 /= length tix2
|| len1 /= length tix1
|| len2 /= length tix2
-> error $ "mismatched in module " ++ m
| otherwise ->
TixModule m hash1 len1 (zipWith f tix1 tix2)
(Just m1,Nothing) ->
m1
(Nothing,Just m2) ->
m2
_ -> error "impossible"
| m <- Set.toList (theMergeFun modComb m1s m2s)
]
where
m1s = Set.fromList $ map tixModuleName t1
where
m1s = Set.fromList $ map tixModuleName t1
m2s = Set.fromList $ map tixModuleName t2
fm1 = Map.fromList [ (tixModuleName tix,tix)
| tix <- t1
]
fm2 = Map.fromList [ (tixModuleName tix,tix)
| tix <- t2
]
fm1 = Map.fromList [ (tixModuleName tix,tix)
| tix <- t1
]
fm2 = Map.fromList [ (tixModuleName tix,tix)
| tix <- t2
]
-- What I would give for a hyperstrict :-)
......@@ -172,7 +172,7 @@ instance Strict Integer where
instance Strict Int where
strict i = i
instance Strict Hash where -- should be fine, because Hash is a newtype round an Int
instance Strict Hash where -- should be fine, because Hash is a newtype round an Int
strict i = i
instance Strict Char where
......@@ -186,10 +186,10 @@ instance (Strict a, Strict b) => Strict (a,b) where
strict (a,b) = (((,) $! strict a) $! strict b)
instance Strict Tix where
strict (Tix t1) =
Tix $! strict t1
strict (Tix t1) =
Tix $! strict t1
instance Strict TixModule where
strict (TixModule m1 p1 i1 t1) =
((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
strict (TixModule m1 p1 i1 t1) =
((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
......@@ -13,41 +13,41 @@ import Data.Tree
------------------------------------------------------------------------------
draft_options :: FlagOptSeq
draft_options
draft_options
= excludeOpt
. includeOpt
. srcDirOpt
. hpcDirOpt
. outputOpt
draft_plugin :: Plugin
draft_plugin = Plugin { name = "draft"
, usage = "[OPTION] .. <TIX_FILE>"
, options = draft_options
, summary = "Generate draft overlay that provides 100% coverage"
, implementation = draft_main
, init_flags = default_flags
, final_flags = default_final_flags
}
, usage = "[OPTION] .. <TIX_FILE>"
, options = draft_options
, summary = "Generate draft overlay that provides 100% coverage"
, implementation = draft_main
, init_flags = default_flags
, final_flags = default_final_flags
}
------------------------------------------------------------------------------
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
`Set.union`
includeMods hpcflags }
let prog = getTixFileName $ progName
tix <- readTix prog
let hpcflags1 = hpcflags
{ includeMods = Set.fromList mods
`Set.union`
includeMods hpcflags }
let prog = getTixFileName $ progName
tix <- readTix prog
case tix of
Just (Tix tickCounts) -> do
outs <- sequence
[ makeDraft hpcflags1 tixModule
| tixModule@(TixModule m _ _ _) <- tickCounts
, allowModule hpcflags1 m
]
outs <- sequence
[ makeDraft hpcflags1 tixModule
| tixModule@(TixModule m _ _ _) <- tickCounts
, allowModule hpcflags1 m
]
case outputFile hpcflags1 of
"-" -> putStrLn (unlines outs)
out -> writeFile out (unlines outs)
......@@ -55,13 +55,13 @@ draft_main hpcflags (progName:mods) = do
makeDraft :: Flags -> TixModule -> IO String
makeDraft hpcflags tix = do
makeDraft hpcflags tix = do
let modu = tixModuleName tix
tixs = tixModuleTixs tix
(Mix filepath _ _ _ entries) <- readMixWithFlags hpcflags (Right tix)
let forest = createMixEntryDom
let forest = createMixEntryDom
[ (srcspan,(box,v > 0))
| ((srcspan,box),v) <- zip entries tixs
]
......@@ -77,7 +77,7 @@ makeDraft hpcflags tix = do
hsMap = Map.fromList (zip [1..] $ lines hs)
let quoteString = show
let firstLine pos = case fromHpcPos pos of
(ln,_,_,_) -> ln
......@@ -88,10 +88,10 @@ makeDraft hpcflags tix = do
++ "on line " ++ show (firstLine pos) ++ ";"
showPleaseTick d (TickExp pos) =
spaces d ++ "tick "
++ if '\n' `elem` txt
++ if '\n' `elem` txt
then "at position " ++ show pos ++ ";"
else quoteString txt ++ " " ++ "on line " ++ show (firstLine pos) ++ ";"
where
txt = grabHpcPos hsMap pos
......@@ -133,8 +133,8 @@ findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _)
findNotTickedFromTree (Node (pos,(LocalBox nm,False):_) _)
= [ TickFun nm pos ]
findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):_) children)
= mkTickInside nm pos (findNotTickedFromList children) []
findNotTickedFromTree (Node (pos,_:others) children) =
= mkTickInside nm pos (findNotTickedFromList children) []
findNotTickedFromTree (Node (pos,_:others) children) =
findNotTickedFromTree (Node (pos,others) children)
findNotTickedFromTree (Node (_, []) children) = findNotTickedFromList children
......
......@@ -9,29 +9,29 @@ import Trace.Hpc.Tix
import Trace.Hpc.Mix
import System.Exit
data Flags = Flags
{ outputFile :: String
data Flags = Flags
{ outputFile :: String
, includeMods :: Set.Set String
, excludeMods :: Set.Set String
, hpcDir :: String
, srcDirs :: [String]
, destDir :: String
, hpcDir :: String
, srcDirs :: [String]
, destDir :: String
, perModule :: Bool
, decList :: Bool
, xmlOutput :: Bool
, perModule :: Bool
, decList :: Bool
, xmlOutput :: Bool
, funTotals :: Bool
, altHighlight :: Bool
, combineFun :: CombineFun -- tick-wise combine
, postFun :: PostFun --
, mergeModule :: MergeFun -- module-wise merge
, combineFun :: CombineFun -- tick-wise combine
, postFun :: PostFun --
, mergeModule :: MergeFun -- module-wise merge
}
default_flags :: Flags
default_flags = Flags
{ outputFile = "-"
{ outputFile = "-"
, includeMods = Set.empty
, excludeMods = Set.empty
, hpcDir = ".hpc"
......@@ -39,15 +39,15 @@ default_flags = Flags
, destDir = "."
, perModule = False
, decList = False
, xmlOutput = False
, decList = False
, xmlOutput = False
, funTotals = False
, altHighlight = False
, combineFun = ADD
, postFun = ID
, mergeModule = INTERSECTION
, mergeModule = INTERSECTION
}
......@@ -55,10 +55,10 @@ default_flags = Flags
-- depends on if specific flags we used.
default_final_flags :: Flags -> Flags
default_final_flags flags = flags
default_final_flags flags = flags
{ srcDirs = if null (srcDirs flags)
then ["."]
else srcDirs flags
then ["."]
else srcDirs flags
}
type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
......@@ -76,10 +76,10 @@ 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]"
excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
$ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
$ \ a f -> f { includeMods = a `Set.insert` includeMods f }
hpcDirOpt = anArg "hpcdir" "sub-directory that contains .mix files" "DIR"
......@@ -87,92 +87,92 @@ hpcDirOpt = anArg "hpcdir" "sub-directory that contains .mix files" "
. infoArg "default .hpc [rarely used]"
srcDirOpt = anArg "srcdir" "path to source directory of .hs files" "DIR"
(\ a f -> f { srcDirs = srcDirs f ++ [a] })
. infoArg "multi-use of srcdir possible"
(\ a f -> f { srcDirs = srcDirs f ++ [a] })
. infoArg "multi-use of srcdir possible"
destDirOpt = anArg "destdir" "path to write output to" "DIR"
$ \ a f -> f { destDir = a }
$ \ a f -> f { destDir = a }
outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
-- markup
perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
decListOpt = noArg "decl-list" "show unused decls" $ \ f -> f { decList = True }
xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True }
funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts"
$ \ f -> f { funTotals = True }
altHighlightOpt
= noArg "highlight-covered" "highlight covered code, rather that code gaps"
$ \ f -> f { altHighlight = True }
combineFunOpt = anArg "function"
"combine .tix files with join function, default = ADD" "FUNCTION"
$ \ a f -> case reads (map toUpper a) of
[(c,"")] -> f { combineFun = c }
_ -> error $ "no such combine function : " ++ a
combineFunOptInfo = infoArg
$ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)
decListOpt = noArg "decl-list" "show unused decls" $ \ f -> f { decList = True }
xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True }
funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts"
$ \ f -> f { funTotals = True }
altHighlightOpt
= noArg "highlight-covered" "highlight covered code, rather that code gaps"
$ \ f -> f { altHighlight = True }
combineFunOpt = anArg "function"
"combine .tix files with join function, default = ADD" "FUNCTION"
$ \ a f -> case reads (map toUpper a) of
[(c,"")] -> f { combineFun = c }
_ -> error $ "no such combine function : " ++ a
combineFunOptInfo = infoArg
$ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)
mapFunOpt = anArg "function"
"apply function to .tix files, default = ID" "FUNCTION"
$ \ a f -> case reads (map toUpper a) of
[(c,"")] -> f { postFun = c }
_ -> error $ "no such combine function : " ++ a
mapFunOptInfo = infoArg
$ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)
"apply function to .tix files, default = ID" "FUNCTION"
$ \ a f -> case reads (map toUpper a) of
[(c,"")] -> f { postFun = c }
_ -> error $ "no such combine function : " ++ a
mapFunOptInfo = infoArg
$ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)
unionModuleOpt = noArg "union"
"use the union of the module namespace (default is intersection)"
$ \ f -> f { mergeModule = UNION }
"use the union of the module namespace (default is intersection)"
$ \ f -> f { mergeModule = UNION }
-------------------------------------------------------------------------------
readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
readMixWithFlags flags modu = readMix [ dir ++ "/" ++ hpcDir flags
| dir <- srcDirs flags
| dir <- srcDirs flags
] modu
-------------------------------------------------------------------------------
command_usage :: Plugin -> IO ()
command_usage plugin =
command_usage plugin =
putStrLn $
"Usage: hpc " ++ (name plugin) ++ " " ++
(usage plugin) ++
"\n" ++ summary plugin ++ "\n" ++
if null (options plugin [])
then ""
else usageInfo "\n\nOptions:\n" (options plugin [])
"Usage: hpc " ++ (name plugin) ++ " " ++
(usage plugin) ++
"\n" ++ summary plugin ++ "\n" ++
if null (options plugin [])
then ""
else usageInfo "\n\nOptions:\n" (options plugin [])
hpcError :: Plugin -> String -> IO a
hpcError plugin msg = do
putStrLn $ "Error: " ++ msg
command_usage plugin
exitFailure
-------------------------------------------------------------------------------
data Plugin = Plugin { name :: String
, usage :: String
, options :: FlagOptSeq
, summary :: String
, implementation :: Flags -> [String] -> IO ()
, init_flags :: Flags
, final_flags :: Flags -> Flags
}
, usage :: String
, options :: FlagOptSeq
, summary :: String
, implementation :: Flags -> [String] -> IO ()
, init_flags :: Flags
, final_flags :: Flags -> Flags
}
------------------------------------------------------------------------------
-- filterModules takes a list of candidate modules,
-- and
-- filterModules takes a list of candidate modules,
-- and
-- * excludes the excluded modules
-- * includes the rest if there are no explicity included modules
-- * otherwise, accepts just the included modules.
allowModule :: Flags -> String -> Bool
allowModule flags full_mod
allowModule flags full_mod
| full_mod' `Set.member` excludeMods flags = False
| pkg_name `Set.member` excludeMods flags = False
| mod_name `Set.member` excludeMods flags = False
......@@ -180,38 +180,38 @@ allowModule flags full_mod
| full_mod' `Set.member` includeMods flags = True
| pkg_name `Set.member` includeMods flags = True
| mod_name `Set.member` includeMods flags = True
| otherwise = False
| otherwise = False
where
full_mod' = pkg_name ++ mod_name
-- pkg name always ends with '/', main
(pkg_name,mod_name) =
case span (/= '/') full_mod of
(p,'/':m) -> (p ++ ":",m)
(m,[]) -> (":",m)
_ -> error "impossible case in allowModule"
-- pkg name always ends with '/', main
(pkg_name,mod_name) =
case span (/= '/') full_mod of
(p,'/':m) -> (p ++ ":",m)
(m,[]) -> (":",m)
_ -> error "impossible case in allowModule"
filterTix :: Flags -> Tix -> Tix
filterTix flags (Tix tixs) =
Tix $ filter (allowModule flags . tixModuleName) tixs