diff options
author | David Binder <david.binder@uni-tuebingen.de> | 2023-01-06 19:26:01 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-03-08 01:24:17 -0500 |
commit | f3ff7cb1888e2d96e037cfbfa97b72cd536a5766 (patch) | |
tree | 50d9d1afbd2d6a508272c2dc3a4e7c36f44a71b3 /utils | |
parent | 2aa0770845631e4355f55694f49b3e4b66ecf751 (diff) | |
download | haskell-f3ff7cb1888e2d96e037cfbfa97b72cd536a5766.tar.gz |
Remove utils/hpc subdirectory and its contents
Diffstat (limited to 'utils')
-rw-r--r-- | utils/hpc/HpcCombine.hs | 197 | ||||
-rw-r--r-- | utils/hpc/HpcDraft.hs | 144 | ||||
-rw-r--r-- | utils/hpc/HpcFlags.hs | 268 | ||||
-rw-r--r-- | utils/hpc/HpcLexer.hs | 57 | ||||
-rw-r--r-- | utils/hpc/HpcMarkup.hs | 485 | ||||
-rw-r--r-- | utils/hpc/HpcOverlay.hs | 157 | ||||
-rw-r--r-- | utils/hpc/HpcParser.y | 106 | ||||
-rw-r--r-- | utils/hpc/HpcReport.hs | 277 | ||||
-rw-r--r-- | utils/hpc/HpcShowTix.hs | 63 | ||||
-rw-r--r-- | utils/hpc/HpcUtils.hs | 37 | ||||
-rw-r--r-- | utils/hpc/Main.hs | 217 | ||||
-rw-r--r-- | utils/hpc/Makefile | 15 | ||||
-rw-r--r-- | utils/hpc/hpc-bin.cabal | 44 | ||||
-rw-r--r-- | utils/hpc/hpc.wrapper | 2 |
14 files changed, 0 insertions, 2069 deletions
diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs deleted file mode 100644 index 864b1054d0..0000000000 --- a/utils/hpc/HpcCombine.hs +++ /dev/null @@ -1,197 +0,0 @@ ---------------------------------------------------------- --- The main program for the hpc-add tool, part of HPC. --- Andy Gill, Oct 2006 ---------------------------------------------------------- - -module HpcCombine (sum_plugin,combine_plugin,map_plugin) where - -import Trace.Hpc.Tix -import Trace.Hpc.Util - -import HpcFlags - -import Control.Monad -import qualified Data.Set as Set -import qualified Data.Map as Map - ------------------------------------------------------------------------------- -sum_options :: FlagOptSeq -sum_options - = excludeOpt - . includeOpt - . outputOpt - . unionModuleOpt - . verbosityOpt - -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 - } - -combine_options :: FlagOptSeq -combine_options - = excludeOpt - . includeOpt - . outputOpt - . combineFunOpt - . combineFunOptInfo - . unionModuleOpt - . verbosityOpt - -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 - } - -map_options :: FlagOptSeq -map_options - = excludeOpt - . includeOpt - . outputOpt - . mapFunOpt - . mapFunOptInfo - . unionModuleOpt - . verbosityOpt - -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 - } - ------------------------------------------------------------------------------- - -sum_main :: Flags -> [String] -> IO () -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 - - case outputFile flags of - "-" -> putStrLn (show tix') - out -> writeTix out tix' - -combine_main :: Flags -> [String] -> IO () -combine_main flags [first_file,second_file] = do - let f = theCombineFun (combineFun flags) - - Just tix1 <- readTix first_file - Just tix2 <- readTix second_file - - let tix = mergeTix (mergeModule flags) - f - (filterTix flags tix1) - (filterTix flags tix2) - - case outputFile flags of - "-" -> putStrLn (show tix) - out -> writeTix out tix -combine_main _ _ = hpcError combine_plugin $ "need exactly two .tix files to combine" - -map_main :: Flags -> [String] -> IO () -map_main flags [first_file] = do - let f = thePostFun (postFun flags) - - Just tix <- readTix first_file - - let (Tix inside_tix) = filterTix flags tix - let tix' = Tix [ TixModule m p i (map f t) - | 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" - -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, --- as long as the total is the same; will require normalization. - -mergeTix :: MergeFun - -> (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) - ] - 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 - ] - - --- What I would give for a hyperstrict :-) --- This makes things about 100 times faster. -class Strict a where - strict :: a -> a - -instance Strict Integer where - strict i = i - -instance Strict Int where - strict i = i - -instance Strict Hash where -- should be fine, because Hash is a newtype round an Int - strict i = i - -instance Strict Char where - strict i = i - -instance Strict a => Strict [a] where - strict (a:as) = (((:) $! strict a) $! strict as) - strict [] = [] - -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 - -instance Strict TixModule where - strict (TixModule m1 p1 i1 t1) = - ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1) diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs deleted file mode 100644 index f93e397353..0000000000 --- a/utils/hpc/HpcDraft.hs +++ /dev/null @@ -1,144 +0,0 @@ -module HpcDraft (draft_plugin) where - -import Trace.Hpc.Tix -import Trace.Hpc.Mix -import Trace.Hpc.Util - -import HpcFlags - -import qualified Data.Set as Set -import qualified Data.Map as Map -import HpcUtils -import Data.Tree - ------------------------------------------------------------------------------- -draft_options :: FlagOptSeq -draft_options - = excludeOpt - . includeOpt - . srcDirOpt - . hpcDirOpt - . resetHpcDirsOpt - . outputOpt - . verbosityOpt - -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 - } - ------------------------------------------------------------------------------- - -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 - case tix of - Just (Tix tickCounts) -> do - outs <- sequence - [ makeDraft hpcflags1 tixModule - | tixModule@(TixModule m _ _ _) <- tickCounts - , allowModule hpcflags1 m - ] - case outputFile hpcflags1 of - "-" -> putStrLn (unlines outs) - out -> writeFile out (unlines outs) - Nothing -> hpcError draft_plugin $ "unable to find tix file for:" ++ progName - - -makeDraft :: Flags -> TixModule -> IO String -makeDraft hpcflags tix = do - let modu = tixModuleName tix - tixs = tixModuleTixs tix - - (Mix filepath _ _ _ entries) <- readMixWithFlags hpcflags (Right tix) - - let forest = createMixEntryDom - [ (srcspan,(box,v > 0)) - | ((srcspan,box),v) <- zip entries tixs - ] - --- let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span) --- putStrLn $ drawForest $ map (fmap show) $ forest - - let non_ticked = findNotTickedFromList forest - - hs <- readFileFromPath (hpcError draft_plugin) filepath (srcDirs hpcflags) - - let hsMap :: Map.Map Int String - hsMap = Map.fromList (zip [1..] $ lines hs) - - let quoteString = show - - let firstLine pos = case fromHpcPos pos of - (ln,_,_,_) -> ln - - - let showPleaseTick :: Int -> PleaseTick -> String - showPleaseTick d (TickFun str pos) = - spaces d ++ "tick function \"" ++ last str ++ "\" " - ++ "on line " ++ show (firstLine pos) ++ ";" - showPleaseTick d (TickExp pos) = - spaces d ++ "tick " - ++ if '\n' `elem` txt - then "at position " ++ show pos ++ ";" - else quoteString txt ++ " " ++ "on line " ++ show (firstLine pos) ++ ";" - - where - txt = grabHpcPos hsMap pos - - 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 modu) ++ " {\n" ++ - showPleaseTicks 2 non_ticked ++ "}" - -fixPackageSuffix :: String -> String -fixPackageSuffix modu = case span (/= '/') modu of - (before,'/':after) -> before ++ ":" ++ after - _ -> modu - -data PleaseTick - = TickFun [String] HpcPos - | TickExp HpcPos - | TickInside [String] HpcPos [PleaseTick] - deriving Show - -mkTickInside :: [String] -> HpcPos -> [PleaseTick] - -> [PleaseTick] -> [PleaseTick] -mkTickInside _ _ [] = id -mkTickInside nm pos inside = (TickInside nm pos inside :) - -findNotTickedFromTree :: MixEntryDom [(BoxLabel,Bool)] -> [PleaseTick] -findNotTickedFromTree (Node (pos,(ExpBox {},False):_) _) = [TickExp pos] -findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _) - = [ TickFun nm pos ] -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) = - findNotTickedFromTree (Node (pos,others) 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 deleted file mode 100644 index 2d78375003..0000000000 --- a/utils/hpc/HpcFlags.hs +++ /dev/null @@ -1,268 +0,0 @@ --- (c) 2007 Andy Gill - -module HpcFlags where - -import System.Console.GetOpt -import qualified Data.Set as Set -import Data.Char -import Trace.Hpc.Tix -import Trace.Hpc.Mix -import System.Exit -import System.FilePath - -data Flags = Flags - { outputFile :: String - , includeMods :: Set.Set String - , excludeMods :: Set.Set String - , hpcDirs :: [String] - , srcDirs :: [String] - , destDir :: String - - , perModule :: Bool - , decList :: Bool - , xmlOutput :: Bool - - , funTotals :: Bool - , altHighlight :: Bool - - , combineFun :: CombineFun -- tick-wise combine - , postFun :: PostFun -- - , mergeModule :: MergeFun -- module-wise merge - - , verbosity :: Verbosity - } - -default_flags :: Flags -default_flags = Flags - { outputFile = "-" - , includeMods = Set.empty - , excludeMods = Set.empty - , hpcDirs = [".hpc"] - , srcDirs = [] - , destDir = "." - - , perModule = False - , decList = False - , xmlOutput = False - - , funTotals = False - , altHighlight = False - - , combineFun = ADD - , postFun = ID - , mergeModule = INTERSECTION - - , verbosity = Normal - } - - -data Verbosity = Silent | Normal | Verbose - deriving (Eq, Ord) - -verbosityFromString :: String -> Verbosity -verbosityFromString "0" = Silent -verbosityFromString "1" = Normal -verbosityFromString "2" = Verbose -verbosityFromString v = error $ "unknown verbosity: " ++ v - - --- 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 ["."] - else srcDirs flags - } - -type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)] - -noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq -noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail - -anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq -anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail - -infoArg :: String -> FlagOptSeq -infoArg info = (:) $ Option [] [] (NoArg $ id) info - -excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt, - destDirOpt, outputOpt, verbosityOpt, - 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 } - -includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" - $ \ a f -> f { includeMods = a `Set.insert` includeMods f } - -hpcDirOpt = anArg "hpcdir" "append sub-directory that contains .mix files" "DIR" - (\ a f -> f { hpcDirs = hpcDirs f ++ [a] }) - . infoArg "default .hpc [rarely used]" - -resetHpcDirsOpt = noArg "reset-hpcdirs" "empty the list of hpcdir's" - (\ f -> f { hpcDirs = [] }) - . infoArg "[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" - -destDirOpt = anArg "destdir" "path to write output to" "DIR" - $ \ a f -> f { destDir = a } - - -outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a } - -verbosityOpt = anArg "verbosity" "verbosity level, 0-2" "[0-2]" - (\ a f -> f { verbosity = verbosityFromString a }) - . infoArg "default 1" - --- 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) - -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) - -unionModuleOpt = noArg "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 - | dir <- srcDirs flags - , hpcDir <- hpcDirs flags - ] modu - -------------------------------------------------------------------------------- - -command_usage :: Plugin -> IO () -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 []) - -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 - } - ------------------------------------------------------------------------------- - --- filterModules takes a list of candidate modules, --- and --- * excludes the excluded modules --- * includes the rest if there are no explicitly included modules --- * otherwise, accepts just the included modules. - -allowModule :: Flags -> String -> Bool -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 - | Set.null (includeMods flags) = True - | full_mod' `Set.member` includeMods flags = True - | pkg_name `Set.member` includeMods flags = True - | mod_name `Set.member` includeMods flags = True - | 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" - -filterTix :: Flags -> Tix -> Tix -filterTix flags (Tix tixs) = - Tix $ filter (allowModule flags . tixModuleName) tixs - - - ------------------------------------------------------------------------------- --- HpcCombine specifics - -data CombineFun = ADD | DIFF | SUB - deriving (Eq,Show, Read, Enum) - -theCombineFun :: CombineFun -> Integer -> Integer -> Integer -theCombineFun fn = case fn of - ADD -> \ l r -> l + r - SUB -> \ l r -> max 0 (l - r) - DIFF -> \ g b -> if g > 0 then 0 else min 1 b - -foldFuns :: [ (String,CombineFun) ] -foldFuns = [ (show comb,comb) - | comb <- [ADD .. SUB] - ] - -data PostFun = ID | INV | ZERO - deriving (Eq,Show, Read, Enum) - -thePostFun :: PostFun -> Integer -> Integer -thePostFun ID x = x -thePostFun INV 0 = 1 -thePostFun INV _ = 0 -thePostFun ZERO _ = 0 - -postFuns :: [(String, PostFun)] -postFuns = [ (show pos,pos) - | pos <- [ID .. ZERO] - ] - - -data MergeFun = INTERSECTION | UNION - deriving (Eq,Show, Read, Enum) - -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 deleted file mode 100644 index 5610b7a89c..0000000000 --- a/utils/hpc/HpcLexer.hs +++ /dev/null @@ -1,57 +0,0 @@ -module HpcLexer where - -import Data.Char - -data Token - = ID String - | SYM Char - | INT Int - | STR String - | CAT String - deriving (Eq,Show) - -initLexer :: String -> [Token] -initLexer str = [ t | (_,_,t) <- lexer str 1 1 ] - -lexer :: String -> Int -> Int -> [(Int,Int,Token)] -lexer (c:cs) line column - | c == '\n' = lexer cs (succ line) 1 - | c == '\"' = lexerSTR cs line (succ column) - | c == '[' = lexerCAT cs "" line (succ column) - | c `elem` "{};-:" - = (line,column,SYM c) : lexer cs line (succ column) - | isSpace c = lexer cs line (succ column) - | isAlpha c = lexerKW cs [c] line (succ column) - | isDigit c = lexerINT cs [c] line (succ column) - | otherwise = error "lexer failure" -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 [] _ _ _ = error "lexer failure in CAT" - -test :: IO () -test = do - t <- readFile "EXAMPLE.tc" - print (initLexer t) - diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs deleted file mode 100644 index d156f261cb..0000000000 --- a/utils/hpc/HpcMarkup.hs +++ /dev/null @@ -1,485 +0,0 @@ ---------------------------------------------------------- --- The main program for the hpc-markup tool, part of HPC. --- Andy Gill and Colin Runciman, June 2006 ---------------------------------------------------------- - -module HpcMarkup (markup_plugin) where - -import Trace.Hpc.Mix -import Trace.Hpc.Tix -import Trace.Hpc.Util (HpcPos, fromHpcPos, writeFileUtf8) - -import HpcFlags -import HpcUtils - -import System.FilePath -import Data.List (sortBy, find) -import Data.Maybe(fromJust) -import Data.Semigroup as Semi -import Data.Array -import Control.Monad -import qualified Data.Set as Set - ------------------------------------------------------------------------------- - -markup_options :: FlagOptSeq -markup_options - = excludeOpt - . includeOpt - . srcDirOpt - . hpcDirOpt - . resetHpcDirsOpt - . funTotalsOpt - . altHighlightOpt - . destDirOpt - . verbosityOpt - -markup_plugin :: Plugin -markup_plugin = Plugin { name = "markup" - , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" - , options = markup_options - , summary = "Markup Haskell source with program coverage" - , implementation = markup_main - , init_flags = default_flags - , final_flags = default_final_flags - } - ------------------------------------------------------------------------------- - -markup_main :: Flags -> [String] -> IO () -markup_main flags (prog:modNames) = do - let hpcflags1 = flags - { includeMods = Set.fromList modNames - `Set.union` - includeMods flags } - let Flags - { funTotals = theFunTotals - , altHighlight = invertOutput - , destDir = dest_dir - } = hpcflags1 - - mtix <- readTix (getTixFileName prog) - Tix tixs <- case mtix of - Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog - Just a -> return a - - mods <- - sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput - | tix <- tixs - , allowModule hpcflags1 (tixModuleName tix) - ] - - let index_name = "hpc_index" - index_fun = "hpc_index_fun" - index_alt = "hpc_index_alt" - index_exp = "hpc_index_exp" - - let writeSummary filename cmp = do - let mods' = sortBy cmp mods - - unless (verbosity flags < Normal) $ - putStrLn $ "Writing: " ++ (filename <.> "html") - - writeFileUtf8 (dest_dir </> filename <.> "html") $ - "<html>" ++ - "<head>" ++ - "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">" ++ - "<style type=\"text/css\">" ++ - "table.bar { background-color: #f25913; }\n" ++ - "td.bar { background-color: #60de51; }\n" ++ - "td.invbar { background-color: #f25913; }\n" ++ - "table.dashboard { border-collapse: collapse ; border: solid 1px black }\n" ++ - ".dashboard td { border: solid 1px black }\n" ++ - ".dashboard th { border: solid 1px black }\n" ++ - "</style>\n" ++ - "</head>" ++ - "<body>" ++ - "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++ - "<tr>" ++ - "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++ - "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++ - "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++ - "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++ - "</tr>" ++ - "<tr>" ++ - "<th>%</th>" ++ - "<th colspan=2>covered / total</th>" ++ - "<th>%</th>" ++ - "<th colspan=2>covered / total</th>" ++ - "<th>%</th>" ++ - "<th colspan=2>covered / total</th>" ++ - "</tr>" ++ - concat [ showModuleSummary (modName,fileName,modSummary) - | (modName,fileName,modSummary) <- mods' - ] ++ - "<tr></tr>" ++ - showTotalSummary (mconcat - [ modSummary - | (_,_,modSummary) <- mods' - ]) - ++ "</table></body></html>\n" - - writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2 - - writeSummary index_fun $ \ (_,_,s1) (_,_,s2) -> - compare (percent (topFunTicked s2) (topFunTotal s2)) - (percent (topFunTicked s1) (topFunTotal s1)) - - writeSummary index_alt $ \ (_,_,s1) (_,_,s2) -> - compare (percent (altTicked s2) (altTotal s2)) - (percent (altTicked s1) (altTotal s1)) - - writeSummary index_exp $ \ (_,_,s1) (_,_,s2) -> - compare (percent (expTicked s2) (expTotal s2)) - (percent (expTicked s1) (expTotal s1)) - - -markup_main _ [] - = hpcError markup_plugin $ "no .tix file or executable name specified" - --- Add characters to the left of a string until it is at least as --- large as requested. -padLeft :: Int -> Char -> String -> String -padLeft n c str = go n str - where - -- If the string is already long enough, stop traversing it. - go 0 _ = str - go k [] = replicate k c ++ str - go k (_:xs) = go (k-1) xs - -genHtmlFromMod - :: String - -> Flags - -> TixModule - -> Bool - -> Bool - -> IO (String, [Char], ModuleSummary) -genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do - let theHsPath = srcDirs flags - let modName0 = tixModuleName tix - - (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix) - - let arr_tix :: Array Int Integer - arr_tix = listArray (0,length (tixModuleTixs tix) - 1) - $ tixModuleTixs tix - - let tickedWith :: Int -> Integer - tickedWith n = arr_tix ! n - - isTicked n = tickedWith n /= 0 - - let info = [ (pos,theMarkup) - | (gid,(pos,boxLabel)) <- zip [0 ..] mix' - , let binBox = case (isTicked gid,isTicked (gid+1)) of - (False,False) -> [] - (True,False) -> [TickedOnlyTrue] - (False,True) -> [TickedOnlyFalse] - (True,True) -> [] - , let tickBox = if isTicked gid - then [IsTicked] - else [NotTicked] - , theMarkup <- case boxLabel of - ExpBox {} -> tickBox - TopLevelBox {} - -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox - LocalBox {} -> tickBox - BinBox _ True -> binBox - _ -> [] - ] - - - let modSummary = foldr (.) id - [ \ st -> - case boxLabel of - ExpBox False - -> st { expTicked = ticked (expTicked st) - , expTotal = succ (expTotal st) - } - ExpBox True - -> st { expTicked = ticked (expTicked st) - , expTotal = succ (expTotal st) - , altTicked = ticked (altTicked st) - , altTotal = succ (altTotal st) - } - TopLevelBox _ -> - st { topFunTicked = ticked (topFunTicked st) - , topFunTotal = succ (topFunTotal st) - } - _ -> st - | (gid,(_pos,boxLabel)) <- zip [0 ..] mix' - , let ticked = if isTicked gid - then succ - else id - ] $ mempty - - -- add prefix to modName argument - content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath - - let content' = markup tabStop info content - let addLine n xs = "<span class=\"lineno\">" ++ padLeft 5 ' ' (show n) ++ " </span>" ++ xs - let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines - let fileName = modName0 <.> "hs" <.> "html" - unless (verbosity flags < Normal) $ - putStrLn $ "Writing: " ++ fileName - writeFileUtf8 (dest_dir </> fileName) $ - unlines ["<html>", - "<head>", - "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">", - "<style type=\"text/css\">", - "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }", - if invertOutput - then "span.nottickedoff { color: #404040; background: white; font-style: oblique }" - else "span.nottickedoff { background: " ++ yellow ++ "}", - if invertOutput - then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }" - else "span.istickedoff { background: white }", - "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }", - "span.tickonlytrue { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }", - "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }", - if invertOutput - then "span.decl { font-weight: bold; background: #d0c0ff }" - else "span.decl { font-weight: bold }", - "span.spaces { background: white }", - "</style>", - "</head>", - "<body>", - "<pre>", - concat [ - "<span class=\"decl\">", - "<span class=\"nottickedoff\">never executed</span> ", - "<span class=\"tickonlytrue\">always true</span> ", - "<span class=\"tickonlyfalse\">always false</span></span>"], - "</pre>", - "<pre>"] ++ addLines content' ++ "\n</pre>\n</body>\n</html>\n"; - - - modSummary `seq` return (modName0,fileName,modSummary) - -data Loc = Loc !Int !Int - deriving (Eq,Ord,Show) - -data Markup - = NotTicked - | TickedOnlyTrue - | TickedOnlyFalse - | IsTicked - | TopLevelDecl - Bool -- display entry totals - Integer - deriving (Eq,Show) - -markup :: Int -- ^tabStop - -> [(HpcPos,Markup)] -- random list of tick location pairs - -> String -- text to mark up - -> String -markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs - where - tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark) - | (pos,mark) <- mix - , let (ln1,c1,ln2,c2) = fromHpcPos pos - ] - sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) -> - (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs - -addMarkup :: Int -- tabStop - -> String -- text to mark up - -> Loc -- current location - -> [(Loc,Markup)] -- stack of open ticks, with closing location - -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs - -> String - --- check the pre-condition. ---addMarkup tabStop cs loc os ticks --- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os - ---addMarkup tabStop cs loc os@(_:_) ticks --- | trace (show (loc,os,take 10 ticks)) False = undefined - --- close all open ticks, if we have reached the end -addMarkup _ [] _loc os [] = - concatMap (const closeTick) os -addMarkup tabStop cs loc ((o,_):os) ticks | loc > o = - closeTick ++ addMarkup tabStop cs loc os ticks - ---addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 = --- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks - -addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 = - case os of - ((_,tik'):_) - | not (allowNesting tik0 tik') - -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool - _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks - where - - addTo (t,tik) [] = [(t,tik)] - addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs - | otherwise = (t',tik):(t',tik'):xs - -addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 = - -- throw away this tick, because it is from a previous place ?? - addMarkup tabStop0 cs loc os ticks - -addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks - | ln == ln2 && col < col2 - = addMarkup tabStop0 (' ':'\n':cs) loc os ticks -addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks = - if c0=='\n' && os/=[] then - concatMap (const closeTick) (downToTopLevel os) ++ - c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++ - concatMap (openTick.snd) (reverse (downToTopLevel os)) ++ - addMarkup tabStop0 cs' loc' os ticks - else if c0=='\t' then - expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks - else - escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks - where - (w,cs') = span (`elem` " \t") cs - loc' = foldl (flip incBy) loc (c0:w) - escape '>' = ">" - escape '<' = "<" - escape '"' = """ - escape '&' = "&" - escape c = [c] - - expand :: Int -> String -> String - expand _ "" = "" - expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s - where - c' = tabStopAfter 8 c - expand c (' ':s) = ' ' : expand (c+1) s - expand _ _ = error "bad character in string for expansion" - - incBy :: Char -> Loc -> Loc - incBy '\n' (Loc ln _c) = Loc (succ ln) 1 - incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c) - incBy _ (Loc ln c) = Loc ln (succ c) - - tabStopAfter :: Int -> Int -> Int - tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..]) - - -addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks) - -openTick :: Markup -> String -openTick NotTicked = "<span class=\"nottickedoff\">" -openTick IsTicked = "<span class=\"istickedoff\">" -openTick TickedOnlyTrue = "<span class=\"tickonlytrue\">" -openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">" -openTick (TopLevelDecl False _) = openTopDecl -openTick (TopLevelDecl True 0) - = "<span class=\"funcount\">-- never entered</span>" ++ - openTopDecl -openTick (TopLevelDecl True 1) - = "<span class=\"funcount\">-- entered once</span>" ++ - openTopDecl -openTick (TopLevelDecl True n0) - = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl - where showBigNum n | n <= 9999 = show n - | otherwise = case n `quotRem` 1000 of - (q, r) -> showBigNum' q ++ "," ++ showWith r - showBigNum' n | n <= 999 = show n - | otherwise = case n `quotRem` 1000 of - (q, r) -> showBigNum' q ++ "," ++ showWith r - showWith n = padLeft 3 '0' $ show n - - - -closeTick :: String -closeTick = "</span>" - -openTopDecl :: String -openTopDecl = "<span class=\"decl\">" - -downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)] -downToTopLevel ((_,TopLevelDecl {}):_) = [] -downToTopLevel (o : os) = o : downToTopLevel os -downToTopLevel [] = [] - - --- build in logic for nesting bin boxes - -allowNesting :: Markup -- innermost - -> Markup -- outermost - -> Bool -allowNesting n m | n == m = False -- no need to double nest -allowNesting IsTicked TickedOnlyFalse = False -allowNesting IsTicked TickedOnlyTrue = False -allowNesting _ _ = True - ------------------------------------------------------------------------------- - -data ModuleSummary = ModuleSummary - { expTicked :: !Int - , expTotal :: !Int - , topFunTicked :: !Int - , topFunTotal :: !Int - , altTicked :: !Int - , altTotal :: !Int - } - deriving (Show) - - -showModuleSummary :: (String, String, ModuleSummary) -> String -showModuleSummary (modName,fileName,modSummary) = - "<tr>\n" ++ - "<td> <tt>module <a href=\"" ++ fileName ++ "\">" - ++ modName ++ "</a></tt></td>\n" ++ - showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ - showSummary (altTicked modSummary) (altTotal modSummary) ++ - showSummary (expTicked modSummary) (expTotal modSummary) ++ - "</tr>\n" - -showTotalSummary :: ModuleSummary -> String -showTotalSummary modSummary = - "<tr style=\"background: #e0e0e0\">\n" ++ - "<th align=left> Program Coverage Total</tt></th>\n" ++ - showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++ - showSummary (altTicked modSummary) (altTotal modSummary) ++ - showSummary (expTicked modSummary) (expTotal modSummary) ++ - "</tr>\n" - -showSummary :: (Integral t, Show t) => t -> t -> String -showSummary ticked total = - "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++ - "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++ - "<td width=100>" ++ - (case percent ticked total of - Nothing -> " " - Just w -> bar w "bar" - ) ++ "</td>" - where - showP Nothing = "- " - showP (Just x) = show x ++ "%" - 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>" ++ - "</table></td></tr></table>" - -percent :: (Integral a) => a -> a -> Maybe a -percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total) - -instance Semi.Semigroup ModuleSummary where - (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1) <> (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2) - = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2) - -instance Monoid ModuleSummary where - mempty = ModuleSummary - { expTicked = 0 - , expTotal = 0 - , topFunTicked = 0 - , topFunTotal = 0 - , altTicked = 0 - , altTotal = 0 - } - mappend = (<>) - ------------------------------------------------------------------------------- --- global color palette - -red,green,yellow :: String -red = "#f20913" -green = "#60de51" -yellow = "yellow" diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs deleted file mode 100644 index 44ac6d065a..0000000000 --- a/utils/hpc/HpcOverlay.hs +++ /dev/null @@ -1,157 +0,0 @@ -module HpcOverlay where - -import HpcFlags -import HpcParser -import HpcUtils -import Trace.Hpc.Tix -import Trace.Hpc.Mix -import Trace.Hpc.Util -import qualified Data.Map as Map -import Data.Tree - -overlay_options :: FlagOptSeq -overlay_options - = srcDirOpt - . hpcDirOpt - . resetHpcDirsOpt - . outputOpt - . verbosityOpt - -overlay_plugin :: Plugin -overlay_plugin = Plugin { name = "overlay" - , usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]" - , options = overlay_options - , summary = "Generate a .tix file from an overlay file" - , implementation = overlay_main - , init_flags = default_flags - , final_flags = default_final_flags - } - -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 globals modules) = concatSpec specs - - let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ] - - mod_info <- - sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu) - content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags) - processModule modu content mix mod_spec globals - | (modu, mod_spec) <- Map.toList modules1 - ] - - - let tix = Tix $ mod_info - - case outputFile flags of - "-" -> putStrLn (show tix) - out -> writeFile out (show tix) - - -processModule :: String -- ^ module name - -> String -- ^ module contents - -> Mix -- ^ mix entry for this module - -> [Tick] -- ^ local ticks - -> [ExprTick] -- ^ global ticks - -> IO TixModule -processModule modName modContents (Mix _ _ hash _ entries) locals globals = do - - let hsMap :: Map.Map Int String - hsMap = Map.fromList (zip [1..] $ lines modContents) - - let topLevelFunctions = - Map.fromListWith (++) - [ (nm,[pos]) - | (pos,TopLevelBox [nm]) <- entries - ] - - let inside :: HpcPos -> String -> Bool - inside pos nm = - case Map.lookup nm topLevelFunctions of - Nothing -> False - Just poss -> any (pos `insideHpcPos`) poss - - -- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick - let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool - plzTick pos (ExpBox _) (TickExpression _ match q _) = - qualifier pos q - && case match of - Nothing -> True - Just str -> str == grabHpcPos hsMap pos - plzTick _ _ _ = False - - - plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool - plzTopTick pos label (ExprTick ignore) = plzTick pos label ignore - 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 tixs = Map.fromList - [ (ix, - any (plzTick pos label) globals - || any (plzTopTick pos label) locals) - | (ix,(pos,label)) <- zip [0..] entries - ] - - - -- let show' (srcspan,stuff) = show (srcspan,stuff,grabHpcPos hsMap span) - - let forest = createMixEntryDom - [ (srcspan,ix) - | ((srcspan,_),ix) <- zip entries [0..] - ] - - - -- - let forest2 = addParentToList [] $ forest --- putStrLn $ drawForest $ map (fmap show') $ forest2 - - let isDomList = Map.fromList - [ (ix,filter (/= ix) rng ++ dom) - | (_,(rng,dom)) <- concatMap flatten forest2 - , ix <- rng - ] - - -- We do not use laziness here, because the dominator lists - -- point to their equivent peers, creating loops. - - - let isTicked n = - case Map.lookup n tixs of - Just v -> v - Nothing -> error $ "can not find ix # " ++ show n - - let tixs' = [ case Map.lookup n isDomList of - Just vs -> if any isTicked (n : vs) then 1 else 0 - Nothing -> error $ "can not find ix in dom list # " ++ show n - | n <- [0..(length entries - 1)] - ] - - return $ TixModule modName hash (length tixs') tixs' - -qualifier :: HpcPos -> Maybe Qualifier -> Bool -qualifier _ Nothing = True -qualifier pos (Just (OnLine n)) = n == l1 && n == l2 - where (l1,_,l2,_) = fromHpcPos pos -qualifier pos (Just (AtPosition l1' c1' l2' c2')) - = (l1', c1', l2', c2') == fromHpcPos pos - -concatSpec :: [Spec] -> Spec -concatSpec = foldr - (\ (Spec pre1 body1) (Spec pre2 body2) - -> Spec (pre1 ++ pre2) (body1 ++ body2)) - (Spec [] []) - - - -addParentToTree :: [a] -> MixEntryDom [a] -> MixEntryDom ([a],[a]) -addParentToTree path (Node (pos,a) children) = - Node (pos,(a,path)) (addParentToList (a ++ path) children) - -addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a],[a])] -addParentToList path nodes = map (addParentToTree path) nodes diff --git a/utils/hpc/HpcParser.y b/utils/hpc/HpcParser.y deleted file mode 100644 index bff9530384..0000000000 --- a/utils/hpc/HpcParser.y +++ /dev/null @@ -1,106 +0,0 @@ -{ -module HpcParser where - -import HpcLexer -} - -%name parser -%expect 0 -%tokentype { Token } - -%token - MODULE { ID "module" } - TICK { ID "tick" } - EXPRESSION { ID "expression" } - ON { ID "on" } - LINE { ID "line" } - POSITION { ID "position" } - FUNCTION { ID "function" } - INSIDE { ID "inside" } - AT { ID "at" } - ':' { SYM ':' } - '-' { SYM '-' } - ';' { SYM ';' } - '{' { SYM '{' } - '}' { SYM '}' } - int { INT $$ } - string { STR $$ } - cat { CAT $$ } -%% - -Spec :: { Spec } -Spec : Ticks Modules { Spec ($1 []) ($2 []) } - -Modules :: { L (ModuleName,[Tick]) } -Modules : Modules Module { $1 . ((:) $2) } - | { id } - -Module :: { (ModuleName,[Tick]) } -Module : MODULE string '{' TopTicks '}' - { ($2,$4 []) } - -TopTicks :: { L Tick } -TopTicks : TopTicks TopTick { $1 . ((:) $2) } - | { id } - -TopTick :: { Tick } -TopTick : Tick { ExprTick $1 } - | TICK FUNCTION string optQual optCat ';' - { TickFunction $3 $4 $5 } - | INSIDE string '{' TopTicks '}' - { InsideFunction $2 ($4 []) } - -Ticks :: { L ExprTick } -Ticks : Ticks Tick { $1 . ((:) $2) } - | { id } - -Tick :: { ExprTick } -Tick : TICK optString optQual optCat ';' - { TickExpression False $2 $3 $4 } - -optString :: { Maybe String } -optString : string { Just $1 } - | { Nothing } - -optQual :: { Maybe Qualifier } -optQual : ON LINE int { Just (OnLine $3) } - | AT POSITION int ':' int '-' int ':' int - { Just (AtPosition $3 $5 $7 $9) } - | { Nothing } -optCat :: { Maybe String } -optCat : cat { Just $1 } - | { Nothing } - -{ -type L a = [a] -> [a] - -type ModuleName = String - -data Spec - = Spec [ExprTick] [(ModuleName,[Tick])] - deriving (Show) - -data ExprTick - = TickExpression Bool (Maybe String) (Maybe Qualifier) (Maybe String) - deriving (Show) - -data Tick - = ExprTick ExprTick - | TickFunction String (Maybe Qualifier) (Maybe String) - | InsideFunction String [Tick] - deriving (Show) - -data Qualifier = OnLine Int - | AtPosition Int Int Int Int - deriving (Show) - - - -hpcParser :: String -> IO Spec -hpcParser filename = do - txt <- readFile filename - let tokens = initLexer txt - return $ parser tokens - -happyError e = error $ show (take 10 e) -} diff --git a/utils/hpc/HpcReport.hs b/utils/hpc/HpcReport.hs deleted file mode 100644 index ee5924fcd4..0000000000 --- a/utils/hpc/HpcReport.hs +++ /dev/null @@ -1,277 +0,0 @@ ---------------------------------------------------------- --- The main program for the hpc-report tool, part of HPC. --- Colin Runciman and Andy Gill, June 2006 ---------------------------------------------------------- - -module HpcReport (report_plugin) where - -import Prelude hiding (exp) -import Data.List(sort,intersperse,sortBy) -import HpcFlags -import Trace.Hpc.Mix -import Trace.Hpc.Tix -import Control.Monad hiding (guard) -import qualified Data.Set as Set - -notExpecting :: String -> a -notExpecting s = error ("not expecting "++s) - -data BoxTixCounts = BT {boxCount, tixCount :: !Int} - -btZero :: BoxTixCounts -btZero = BT {boxCount=0, tixCount=0} - -btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts -btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2) - -btPercentage :: String -> BoxTixCounts -> String -btPercentage s (BT b t) = showPercentage s t b - -showPercentage :: String -> Int -> Int -> String -showPercentage s 0 0 = "100% "++s++" (0/0)" -showPercentage s n d = showWidth 3 p++"% "++ - s++ - " ("++show n++"/"++show d++")" - where - p = (n*100) `div` d - showWidth w x0 = replicate (shortOf w (length sx)) ' ' ++ sx - where - sx = show x0 - shortOf x y = if y < x then x-y else 0 - -data BinBoxTixCounts = BBT { binBoxCount - , onlyTrueTixCount - , onlyFalseTixCount - , bothTixCount :: !Int} - -bbtzero :: BinBoxTixCounts -bbtzero = BBT { binBoxCount=0 - , onlyTrueTixCount=0 - , onlyFalseTixCount=0 - , bothTixCount=0} - -bbtPlus :: BinBoxTixCounts -> BinBoxTixCounts -> BinBoxTixCounts -bbtPlus (BBT b1 tt1 ft1 bt1) (BBT b2 tt2 ft2 bt2) = - BBT (b1+b2) (tt1+tt2) (ft1+ft2) (bt1+bt2) - -bbtPercentage :: String -> Bool -> BinBoxTixCounts -> String -bbtPercentage s withdetail (BBT b tt ft bt) = - showPercentage s bt b ++ - if withdetail && bt/=b then - detailFor tt "always True"++ - detailFor ft "always False"++ - detailFor (b-(tt+ft+bt)) "unevaluated" - else "" - where - detailFor n txt = if n>0 then ", "++show n++" "++txt - else "" - -data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts - , guard,cond,qual :: !BinBoxTixCounts - , decPaths :: [[String]]} - -miZero :: ModInfo -miZero = MI { exp=btZero - , alt=btZero - , top=btZero - , loc=btZero - , guard=bbtzero - , cond=bbtzero - , qual=bbtzero - , decPaths = []} - -miPlus :: ModInfo -> ModInfo -> ModInfo -miPlus mi1 mi2 = - MI { exp = exp mi1 `btPlus` exp mi2 - , alt = alt mi1 `btPlus` alt mi2 - , top = top mi1 `btPlus` top mi2 - , loc = loc mi1 `btPlus` loc mi2 - , guard = guard mi1 `bbtPlus` guard mi2 - , cond = cond mi1 `bbtPlus` cond mi2 - , qual = qual mi1 `bbtPlus` qual mi2 - , decPaths = decPaths mi1 ++ decPaths mi2 } - -allBinCounts :: ModInfo -> BinBoxTixCounts -allBinCounts mi = - BBT { binBoxCount = sumAll binBoxCount - , onlyTrueTixCount = sumAll onlyTrueTixCount - , onlyFalseTixCount = sumAll onlyFalseTixCount - , bothTixCount = sumAll bothTixCount } - where - sumAll f = f (guard mi) + f (cond mi) + f (qual mi) - -accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo -accumCounts [] mi = mi -accumCounts ((bl,btc):etc) mi - | single bl = accumCounts etc mi' - where - mi' = case bl of - ExpBox False -> mi{exp = inc (exp mi)} - ExpBox True -> mi{exp = inc (exp mi), alt = inc (alt mi)} - TopLevelBox dp -> mi{top = inc (top mi) - ,decPaths = upd dp (decPaths mi)} - LocalBox dp -> mi{loc = inc (loc mi) - ,decPaths = upd dp (decPaths mi)} - _other -> notExpecting "BoxLabel in accumcounts" - inc (BT {boxCount=bc,tixCount=tc}) = - BT { boxCount = bc+1 - , 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 - mi' = case (bl0,bl1) of - (BinBox GuardBinBox True, BinBox GuardBinBox False) -> - mi{guard = inc (guard mi)} - (BinBox CondBinBox True, BinBox CondBinBox False) -> - mi{cond = inc (cond mi)} - (BinBox QualBinBox True, BinBox QualBinBox False) -> - mi{qual = inc (qual mi)} - _other -> notExpecting "BoxLabel pair in accumcounts" - inc (BBT { binBoxCount=bbc - , onlyTrueTixCount=ttc - , onlyFalseTixCount=ftc - , bothTixCount=btc}) = - BBT { binBoxCount = bbc+1 - , onlyTrueTixCount = ttc + bit (btc0 >0 && btc1==0) - , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0) - , bothTixCount = btc + bit (btc0 >0 && btc1 >0) } - -bit :: Bool -> Int -bit True = 1 -bit False = 0 - -single :: BoxLabel -> Bool -single (ExpBox {}) = True -single (TopLevelBox _) = True -single (LocalBox _) = True -single (BinBox {}) = False - -modInfo :: Flags -> Bool -> TixModule -> IO ModInfo -modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do - Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix) - return (q (accumCounts (zip (map snd mes) tickCounts) miZero)) - where - q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)} - else mi - -modReport :: Flags -> TixModule -> IO () -modReport hpcflags tix@(TixModule moduleName _ _ _) = do - mi <- modInfo hpcflags False tix - if xmlOutput hpcflags - then putStrLn $ " <module name = " ++ show moduleName ++ ">" - else putStrLn ("-----<module "++moduleName++">-----") - printModInfo hpcflags mi - if xmlOutput hpcflags - then putStrLn $ " </module>" - else return () - -printModInfo :: Flags -> ModInfo -> IO () -printModInfo hpcflags mi | xmlOutput hpcflags = do - element "exprs" (xmlBT $ exp mi) - element "booleans" (xmlBBT $ allBinCounts mi) - element "guards" (xmlBBT $ guard mi) - element "conditionals" (xmlBBT $ cond mi) - element "qualifiers" (xmlBBT $ qual mi) - element "alts" (xmlBT $ alt mi) - element "local" (xmlBT $ loc mi) - element "toplevel" (xmlBT $ top mi) -printModInfo hpcflags mi = do - putStrLn (btPercentage "expressions used" (exp mi)) - putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi)) - putStrLn (" "++bbtPercentage "guards" True (guard mi)) - putStrLn (" "++bbtPercentage "'if' conditions" True (cond mi)) - putStrLn (" "++bbtPercentage "qualifiers" True (qual mi)) - putStrLn (btPercentage "alternatives used" (alt mi)) - putStrLn (btPercentage "local declarations used" (loc mi)) - putStrLn (btPercentage "top-level declarations used" (top mi)) - modDecList hpcflags mi - -modDecList :: Flags -> ModInfo -> IO () -modDecList hpcflags mi0 = - when (decList hpcflags && someDecsUnused mi0) $ do - putStrLn "unused declarations:" - mapM_ showDecPath (sort (decPaths mi0)) - where - someDecsUnused mi = tixCount (top mi) < boxCount (top mi) || - tixCount (loc mi) < boxCount (loc mi) - showDecPath dp = putStrLn (" "++ - concat (intersperse "." dp)) - -report_plugin :: Plugin -report_plugin = Plugin { name = "report" - , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" - , options = report_options - , summary = "Output textual report about program coverage" - , implementation = report_main - , init_flags = default_flags - , final_flags = default_final_flags - } - -report_main :: Flags -> [String] -> IO () -report_main hpcflags (progName:mods) = do - let hpcflags1 = hpcflags - { includeMods = Set.fromList mods - `Set.union` - includeMods hpcflags } - let prog = getTixFileName $ progName - tix <- readTix prog - case tix of - Just (Tix tickCounts) -> - makeReport hpcflags1 progName - $ sortBy (\ mod1 mod2 -> tixModuleName mod1 `compare` tixModuleName mod2) - $ [ tix' - | tix'@(TixModule m _ _ _) <- tickCounts - , allowModule hpcflags1 m - ] - Nothing -> hpcError report_plugin $ "unable to find tix file for:" ++ progName -report_main _ [] = - hpcError report_plugin $ "no .tix file or executable name specified" - -makeReport :: Flags -> String -> [TixModule] -> IO () -makeReport hpcflags progName modTcs | xmlOutput hpcflags = do - putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" - putStrLn $ "<coverage name=" ++ show progName ++ ">" - if perModule hpcflags - then mapM_ (modReport hpcflags) modTcs - else return () - mis <- mapM (modInfo hpcflags True) modTcs - putStrLn $ " <summary>" - printModInfo hpcflags (foldr miPlus miZero mis) - putStrLn $ " </summary>" - putStrLn $ "</coverage>" -makeReport hpcflags _ modTcs = - if perModule hpcflags then - mapM_ (modReport hpcflags) modTcs - else do - mis <- mapM (modInfo hpcflags True) modTcs - printModInfo hpcflags (foldr miPlus miZero mis) - -element :: String -> [(String,String)] -> IO () -element tag attrs = putStrLn $ - " <" ++ tag ++ " " - ++ unwords [ x ++ "=" ++ show y - | (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 - . excludeOpt - . includeOpt - . srcDirOpt - . hpcDirOpt - . resetHpcDirsOpt - . xmlOutputOpt - . verbosityOpt diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs deleted file mode 100644 index 551ed88a58..0000000000 --- a/utils/hpc/HpcShowTix.hs +++ /dev/null @@ -1,63 +0,0 @@ -module HpcShowTix (showtix_plugin) where - -import Trace.Hpc.Mix -import Trace.Hpc.Tix - -import HpcFlags - -import qualified Data.Set as Set - -showtix_options :: FlagOptSeq -showtix_options - = excludeOpt - . includeOpt - . srcDirOpt - . hpcDirOpt - . resetHpcDirsOpt - . outputOpt - . verbosityOpt - -showtix_plugin :: Plugin -showtix_plugin = Plugin { name = "show" - , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" - , options = showtix_options - , summary = "Show .tix file in readable, verbose format" - , implementation = showtix_main - , init_flags = default_flags - , final_flags = default_final_flags - } - - -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 - `Set.union` - includeMods flags } - - optTixs <- readTix (getTixFileName prog) - case optTixs of - Nothing -> hpcError showtix_plugin $ "could not read .tix file : " ++ prog - Just (Tix tixs) -> do - tixs_mixs <- sequence - [ do mix <- readMixWithFlags hpcflags1 (Right tix) - return $ (tix,mix) - | tix <- tixs - , allowModule hpcflags1 (tixModuleName tix) - ] - - let rjust n str = take (n - length str) (repeat ' ') ++ str - let ljust n str = str ++ take (n - length str) (repeat ' ') - - 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 - ] - | ( TixModule modName _hash1 _ tixs' - , Mix _file _timestamp _hash2 _tab entries - ) <- tixs_mixs - ] - - return () diff --git a/utils/hpc/HpcUtils.hs b/utils/hpc/HpcUtils.hs deleted file mode 100644 index a5d93fccce..0000000000 --- a/utils/hpc/HpcUtils.hs +++ /dev/null @@ -1,37 +0,0 @@ -module HpcUtils where - -import Trace.Hpc.Util (catchIO, HpcPos, fromHpcPos, readFileUtf8) -import qualified Data.Map as Map -import System.FilePath - -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] --- Spec: dropWhileEndLE p = reverse . dropWhile p . reverse -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- turns \n into ' ' --- | grab's the text behind a HpcPos; -grabHpcPos :: Map.Map Int String -> HpcPos -> String -grabHpcPos hsMap srcspan = - case lns of - [] -> error "grabHpcPos: invalid source span" - [ln] -> (take ((c2 - c1) + 1) $ drop (c1 - 1) ln) - hd : tl -> - let lns1 = drop (c1 -1) hd : tl - lns2 = init lns1 ++ [take (c2 + 1) (last lns1) ] - in foldl1 (\ xs ys -> xs ++ "\n" ++ ys) lns2 - 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 - ) [l1..l2] - - -readFileFromPath :: (String -> IO String) -> String -> [String] -> IO String -readFileFromPath _ filename@('/':_) _ = readFileUtf8 filename -readFileFromPath err filename path0 = readTheFile path0 - where - readTheFile [] = err $ "could not find " ++ show filename - ++ " in path " ++ show path0 - readTheFile (dir:dirs) = - catchIO (readFileUtf8 (dir </> filename)) - (\ _ -> readTheFile dirs) diff --git a/utils/hpc/Main.hs b/utils/hpc/Main.hs deleted file mode 100644 index f7617ec677..0000000000 --- a/utils/hpc/Main.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TupleSections #-} --- (c) 2007 Andy Gill - --- Main driver for Hpc -import Control.Monad (forM, forM_, when) -import Data.Bifunctor (bimap) -import Data.List (intercalate, partition, uncons) -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Maybe (catMaybes, isJust) -import Data.Version -import System.Environment -import System.Exit -import System.Console.GetOpt -import System.Directory (doesPathExist) - -import HpcFlags -import HpcReport -import HpcMarkup -import HpcCombine -import HpcShowTix -import HpcDraft -import HpcOverlay -import Paths_hpc_bin - -helpList :: IO () -helpList = do - putStrLn $ - "Usage: hpc COMMAND ...\n\n" ++ - section "Commands" help ++ - section "Reporting Coverage" reporting ++ - section "Processing Coverage files" processing ++ - section "Coverage Overlays" overlays ++ - section "Others" other ++ - "" - putStrLn "" - putStrLn "or: hpc @response_file_1 @response_file_2 ..." - putStrLn "" - putStrLn "The contents of a Response File must have this format:" - putStrLn "COMMAND ..." - putStrLn "" - putStrLn "example:" - putStrLn "report my_library.tix --include=ModuleA \\" - putStrLn "--include=ModuleB" - where - help = ["help"] - reporting = ["report","markup"] - overlays = ["overlay","draft"] - processing = ["sum","combine","map"] - other = [ name hook - | hook <- hooks - , name hook `notElem` - (concat [help,reporting,processing,overlays]) - ] - -section :: String -> [String] -> String -section _ [] = "" -section msg cmds = msg ++ ":\n" - ++ unlines [ take 14 (" " ++ cmd ++ repeat ' ') ++ summary hook - | cmd <- cmds - , hook <- hooks - , name hook == cmd - ] - -dispatch :: [String] -> IO () -dispatch [] = do - helpList - exitWith ExitSuccess -dispatch (txt:args0) = do - case lookup txt hooks' of - Just plugin -> parse plugin args0 - _ -> case getResponseFileName txt of - Nothing -> parse help_plugin (txt:args0) - Just firstResponseFileName -> do - let - (responseFileNames', nonResponseFileNames) = partitionFileNames args0 - -- if arguments are combination of Response Files and non-Response Files, exit with error - when (length nonResponseFileNames > 0) $ do - let - putStrLn $ "First argument '" <> txt <> "' is a Response File, " <> - "followed by non-Response File(s): '" <> intercalate "', '" nonResponseFileNames <> "'" - putStrLn $ "When first argument is a Response File, " <> - "all arguments should be Response Files." - exitFailure - let - responseFileNames :: NonEmpty FilePath - responseFileNames = firstResponseFileName :| responseFileNames' - - forM_ responseFileNames $ \responseFileName -> do - exists <- doesPathExist responseFileName - when (not exists) $ do - putStrLn $ "Response File '" <> responseFileName <> "' does not exist" - exitFailure - - -- read all Response Files - responseFileNamesAndText :: NonEmpty (FilePath, String) <- - forM responseFileNames $ \responseFileName -> - fmap (responseFileName, ) (readFile responseFileName) - forM_ responseFileNamesAndText $ \(responseFileName, responseFileText) -> - -- parse first word of Response File, which should be a command - case uncons $ words responseFileText of - Nothing -> do - putStrLn $ "Response File '" <> responseFileName <> "' has no command" - exitFailure - Just (responseFileCommand, args1) -> case lookup responseFileCommand hooks' of - -- check command for validity - -- It is important than a Response File cannot specify another Response File; - -- this is prevented - Nothing -> do - putStrLn $ "Response File '" <> responseFileName <> - "' command '" <> responseFileCommand <> "' invalid" - exitFailure - Just plugin -> do - putStrLn $ "Response File '" <> responseFileName <> "':" - parse plugin args1 - - where - getResponseFileName :: String -> Maybe FilePath - getResponseFileName s = do - (firstChar, filename) <- uncons s - if firstChar == '@' - then pure filename - else Nothing - - -- first member of tuple is list of Response File names, - -- second member of tuple is list of all other arguments - partitionFileNames :: [String] -> ([FilePath], [String]) - partitionFileNames xs = let - hasFileName :: [(String, Maybe FilePath)] - hasFileName = fmap (\x -> (x, getResponseFileName x)) xs - (fileNames, nonFileNames) :: ([Maybe FilePath], [String]) = - bimap (fmap snd) (fmap fst) $ partition (isJust . snd) hasFileName - in (catMaybes fileNames, nonFileNames) - - parse plugin args = - case getOpt Permute (options plugin []) args of - (_,_,errs) | not (null errs) - -> do putStrLn "hpc failed:" - sequence_ [ putStr (" " ++ err) - | err <- errs - ] - putStrLn $ "\n" - command_usage plugin - exitFailure - (o,ns,_) -> do - let flags = final_flags plugin - . 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 - , sum_plugin - , combine_plugin - , map_plugin - , showtix_plugin - , overlay_plugin - , draft_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" - , options = help_options - , implementation = help_main - , init_flags = default_flags - , final_flags = default_final_flags - } - -help_main :: Flags -> [String] -> IO () -help_main _ [] = do - helpList - exitWith ExitSuccess -help_main _ (sub_txt:_) = do - case lookup sub_txt hooks' of - Nothing -> do - putStrLn $ "no such HPC command: " <> sub_txt - exitFailure - Just plugin' -> 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" - , options = id - , implementation = version_main - , init_flags = default_flags - , final_flags = default_final_flags - } - -version_main :: Flags -> [String] -> IO () -version_main _ _ = putStrLn ("hpc tools, version " ++ showVersion version) - - ------------------------------------------------------------------------------- diff --git a/utils/hpc/Makefile b/utils/hpc/Makefile deleted file mode 100644 index b8707773ad..0000000000 --- a/utils/hpc/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture -# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying -# -# ----------------------------------------------------------------------------- - -dir = utils/hpc -TOP = ../.. -include $(TOP)/mk/sub-makefile.mk diff --git a/utils/hpc/hpc-bin.cabal b/utils/hpc/hpc-bin.cabal deleted file mode 100644 index 62601cdb07..0000000000 --- a/utils/hpc/hpc-bin.cabal +++ /dev/null @@ -1,44 +0,0 @@ -Name: hpc-bin --- XXX version number: -Version: 0.68 -Copyright: XXX -License: BSD3 --- XXX License-File: LICENSE -Author: XXX -Maintainer: XXX -Synopsis: XXX -Description: XXX -Category: Development -build-type: Simple -cabal-version: 2.0 - -Flag build-tool-depends - Description: Use build-tool-depends - Default: True - -Executable hpc - Default-Language: Haskell2010 - Main-Is: Main.hs - Other-Modules: HpcParser - HpcCombine - HpcDraft - HpcFlags - HpcLexer - HpcMarkup - HpcOverlay - HpcReport - HpcShowTix - HpcUtils - Paths_hpc_bin - - autogen-modules: Paths_hpc_bin - - Build-Depends: base >= 4 && < 5, - directory >= 1 && < 1.4, - filepath >= 1 && < 1.5, - containers >= 0.1 && < 0.7, - array >= 0.1 && < 0.6, - hpc >= 0.6.1 && < 0.7 - - if flag(build-tool-depends) - build-tool-depends: happy:happy >= 1.20.0 diff --git a/utils/hpc/hpc.wrapper b/utils/hpc/hpc.wrapper deleted file mode 100644 index 22982ef0f8..0000000000 --- a/utils/hpc/hpc.wrapper +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -exec "$executablename" ${1+"$@"} |