From c1bc76c3f28955483dc68f8ab89a5c26da860a7e Mon Sep 17 00:00:00 2001 From: Agustin Mista <mista@chalmers.se> Date: Mon, 31 Oct 2022 20:47:58 +0000 Subject: [PATCH] Ormolu pass + consistency tweaks --- src/HpcCombine.hs | 231 +++++++------- src/HpcDraft.hs | 211 +++++++------ src/HpcFlags.hs | 430 ++++++++++++++----------- src/HpcLexer.hs | 67 ++-- src/HpcMain.hs | 308 +++++++++--------- src/HpcMarkup.hs | 786 ++++++++++++++++++++++++---------------------- src/HpcOverlay.hs | 271 ++++++++-------- src/HpcParser.y | 23 +- src/HpcReport.hs | 408 +++++++++++++----------- src/HpcShowTix.hs | 116 +++---- src/HpcUtils.hs | 58 ++-- 11 files changed, 1548 insertions(+), 1361 deletions(-) diff --git a/src/HpcCombine.hs b/src/HpcCombine.hs index f23ce8e..cebb21e 100644 --- a/src/HpcCombine.hs +++ b/src/HpcCombine.hs @@ -3,125 +3,122 @@ -- Andy Gill, Oct 2006 --------------------------------------------------------- -module HpcCombine (sum_plugin,combine_plugin,map_plugin) where +module HpcCombine (sumPlugin, combinePlugin, mapPlugin) where -import Trace.Hpc.Tix -import Trace.Hpc.Util - -import HpcFlags - -import Control.DeepSeq ( force ) -import Control.Monad ( foldM ) -import qualified Data.Set as Set +import Control.DeepSeq +import Control.Monad import qualified Data.Map as Map +import qualified Data.Set as Set +import HpcFlags +import Trace.Hpc.Tix ------------------------------------------------------------------------------ -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 - } + +sumOptions :: FlagOptSeq +sumOptions = + excludeOpt + . includeOpt + . outputOpt + . unionModuleOpt + . verbosityOpt + +sumPlugin :: Plugin +sumPlugin = + Plugin + { name = "sum", + usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]", + options = sumOptions, + summary = "Sum multiple .tix files in a single .tix file", + implementation = sumMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } + +combineOptions :: FlagOptSeq +combineOptions = + excludeOpt + . includeOpt + . outputOpt + . combineFunOpt + . combineFunOptInfo + . unionModuleOpt + . verbosityOpt + +combinePlugin :: Plugin +combinePlugin = + Plugin + { name = "combine", + usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>", + options = combineOptions, + summary = "Combine two .tix files in a single .tix file", + implementation = combineMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } + +mapOptions :: FlagOptSeq +mapOptions = + excludeOpt + . includeOpt + . outputOpt + . mapFunOpt + . mapFunOptInfo + . unionModuleOpt + . verbosityOpt + +mapPlugin :: Plugin +mapPlugin = + Plugin + { name = "map", + usage = "[OPTION] .. <TIX_FILE> ", + options = mapOptions, + summary = "Map a function over a single .tix file", + implementation = mapMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } ------------------------------------------------------------------------------ -sum_main :: Flags -> [String] -> IO () -sum_main _ [] = hpcError sum_plugin $ "no .tix file specified" -sum_main flags (first_file:more_files) = do +sumMain :: Flags -> [String] -> IO () +sumMain _ [] = hpcError sumPlugin "no .tix file specified" +sumMain 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') + "-" -> print tix' out -> writeTix out tix' -combine_main :: Flags -> [String] -> IO () -combine_main flags [first_file,second_file] = do +combineMain :: Flags -> [String] -> IO () +combineMain 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) + let tix = mergeTix (mergeModule flags) f (filterTix flags tix1) (filterTix flags tix2) case outputFile flags of - "-" -> putStrLn (show tix) + "-" -> print tix out -> writeTix out tix -combine_main _ _ = hpcError combine_plugin $ "need exactly two .tix files to combine" +combineMain _ _ = hpcError combinePlugin "need exactly two .tix files to combine" -map_main :: Flags -> [String] -> IO () -map_main flags [first_file] = do +mapMain :: Flags -> [String] -> IO () +mapMain 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 - ] + let tix' = Tix [TixModule m p i (map f t) | TixModule m p i t <- inside_tix] case outputFile flags of - "-" -> putStrLn (show tix') + "-" -> print tix' out -> writeTix out tix' -map_main _ [] = hpcError map_plugin $ "no .tix file specified" -map_main _ _ = hpcError map_plugin $ "to many .tix files specified" +mapMain _ [] = hpcError mapPlugin "no .tix file specified" +mapMain _ _ = hpcError mapPlugin "to many .tix files specified" mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix mergeTixFile flags fn tix file_name = do @@ -131,35 +128,29 @@ mergeTixFile flags fn tix file_name = do -- 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) - ] +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 - ] + 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] diff --git a/src/HpcDraft.hs b/src/HpcDraft.hs index f93e397..7ee6553 100644 --- a/src/HpcDraft.hs +++ b/src/HpcDraft.hs @@ -1,60 +1,59 @@ -module HpcDraft (draft_plugin) where +module HpcDraft (draftPlugin) 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 qualified Data.Set as Set import Data.Tree +import HpcFlags +import HpcUtils +import Trace.Hpc.Mix +import Trace.Hpc.Tix +import Trace.Hpc.Util ------------------------------------------------------------------------------ -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 - } + +draftOptions :: FlagOptSeq +draftOptions = + excludeOpt + . includeOpt + . srcDirOpt + . hpcDirOpt + . resetHpcDirsOpt + . outputOpt + . verbosityOpt + +draftPlugin :: Plugin +draftPlugin = + Plugin + { name = "draft", + usage = "[OPTION] .. <TIX_FILE>", + options = draftOptions, + summary = "Generate draft overlay that provides 100% coverage", + implementation = draftMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } ------------------------------------------------------------------------------ -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 +draftMain :: Flags -> [String] -> IO () +draftMain _ [] = error "draftMain: unhandled case: []" +draftMain 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 - + 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 draftPlugin $ "unable to find tix file for:" ++ progName makeDraft :: Flags -> TixModule -> IO String makeDraft hpcflags tix = do @@ -63,82 +62,94 @@ makeDraft hpcflags tix = do (Mix filepath _ _ _ entries) <- readMixWithFlags hpcflags (Right tix) - let forest = createMixEntryDom - [ (srcspan,(box,v > 0)) - | ((srcspan,box),v) <- zip entries tixs - ] + 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 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) + hs <- readFileFromPath (hpcError draftPlugin) filepath (srcDirs hpcflags) let hsMap :: Map.Map Int String - hsMap = Map.fromList (zip [1..] $ lines hs) + hsMap = Map.fromList (zip [1 ..] $ lines hs) let quoteString = show - let firstLine pos = case fromHpcPos pos of - (ln,_,_,_) -> ln - + 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) ++ ";" + 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 - + 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" + 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 ' ') + spaces d = replicate d ' ' - return $ "module " ++ show (fixPackageSuffix modu) ++ " {\n" ++ - showPleaseTicks 2 non_ticked ++ "}" + return $ + "module " + ++ show (fixPackageSuffix modu) + ++ " {\n" + ++ showPleaseTicks 2 non_ticked + ++ "}" fixPackageSuffix :: String -> String -fixPackageSuffix modu = case span (/= '/') modu of - (before,'/':after) -> before ++ ":" ++ after - _ -> modu +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 + = 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] +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/src/HpcFlags.hs b/src/HpcFlags.hs index 2d78375..e0a7599 100644 --- a/src/HpcFlags.hs +++ b/src/HpcFlags.hs @@ -2,59 +2,53 @@ 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 qualified Data.Set as Set +import System.Console.GetOpt import System.Exit import System.FilePath +import Trace.Hpc.Mix +import Trace.Hpc.Tix -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 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 } +defaultFlags :: Flags +defaultFlags = + 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) @@ -63,131 +57,215 @@ verbosityFromString :: String -> Verbosity verbosityFromString "0" = Silent verbosityFromString "1" = Normal verbosityFromString "2" = Verbose -verbosityFromString v = error $ "unknown verbosity: " ++ v - +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 - } +defaultFinalFlags :: Flags -> Flags +defaultFinalFlags 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 +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" +infoArg info = (:) $ Option [] [] (NoArg id) info + +excludeOpt :: FlagOptSeq +excludeOpt = + anArg + "exclude" + "exclude MODULE and/or PACKAGE" + "[PACKAGE:][MODULE]" + (\a f -> f {excludeMods = a `Set.insert` excludeMods f}) + +includeOpt :: FlagOptSeq +includeOpt = + anArg + "include" + "include MODULE and/or PACKAGE" + "[PACKAGE:][MODULE]" + (\a f -> f {includeMods = a `Set.insert` includeMods f}) + +hpcDirOpt :: FlagOptSeq +hpcDirOpt = + anArg + "hpcdir" + "append sub-directory that contains .mix files" + "DIR" + (\a f -> f {hpcDirs = hpcDirs f ++ [a]}) + . infoArg "default .hpc [rarely used]" + +resetHpcDirsOpt :: FlagOptSeq +resetHpcDirsOpt = + noArg + "reset-hpcdirs" + "empty the list of hpcdir's" + (\f -> f {hpcDirs = []}) + . infoArg "[rarely used]" + +srcDirOpt :: FlagOptSeq +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 :: FlagOptSeq +destDirOpt = + anArg + "destdir" + "path to write output to" + "DIR" + (\a f -> f {destDir = a}) + +outputOpt :: FlagOptSeq +outputOpt = + anArg + "output" + "output FILE" + "FILE" + (\a f -> f {outputFile = a}) + +verbosityOpt :: FlagOptSeq +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 } - +perModuleOpt :: FlagOptSeq +perModuleOpt = + noArg + "per-module" + "show module level detail" + (\f -> f {perModule = True}) + +decListOpt :: FlagOptSeq +decListOpt = + noArg + "decl-list" + "show unused decls" + (\f -> f {decList = True}) + +xmlOutputOpt :: FlagOptSeq +xmlOutputOpt = + noArg + "xml-output" + "show output in XML" + (\f -> f {xmlOutput = True}) + +funTotalsOpt :: FlagOptSeq +funTotalsOpt = + noArg + "fun-entry-count" + "show top-level function entry counts" + (\f -> f {funTotals = True}) + +altHighlightOpt :: FlagOptSeq +altHighlightOpt = + noArg + "highlight-covered" + "highlight covered code, rather that code gaps" + (\f -> f {altHighlight = True}) + +combineFunOpt :: FlagOptSeq +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 :: FlagOptSeq +combineFunOptInfo = + infoArg ("FUNCTION = " ++ foldr1 (\a b -> a ++ " | " ++ b) (map fst foldFuns)) + +mapFunOpt :: FlagOptSeq +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 :: FlagOptSeq +mapFunOptInfo = + infoArg ("FUNCTION = " ++ foldr1 (\a b -> a ++ " | " ++ b) (map fst postFuns)) + +unionModuleOpt :: FlagOptSeq +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 +readMixWithFlags flags = + readMix + [ dir </> hpcDir + | dir <- srcDirs flags, + hpcDir <- hpcDirs flags + ] ------------------------------------------------------------------------------- -command_usage :: Plugin -> IO () -command_usage plugin = +commandUsage :: Plugin -> IO () +commandUsage 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 + putStrLn $ "Error: " ++ msg + commandUsage plugin + exitFailure ------------------------------------------------------------------------------- -data Plugin = Plugin { name :: String - , usage :: String - , options :: FlagOptSeq - , summary :: String - , implementation :: Flags -> [String] -> IO () - , init_flags :: Flags - , final_flags :: Flags -> Flags - } +data Plugin = Plugin + { name :: String, + usage :: String, + options :: FlagOptSeq, + summary :: String, + implementation :: Flags -> [String] -> IO (), + init_flags :: Flags, + final_flags :: Flags -> Flags + } ------------------------------------------------------------------------------ @@ -199,70 +277,60 @@ data Plugin = Plugin { name :: String 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 + | 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" + 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 - - + Tix $ filter (allowModule flags . tixModuleName) tixs ------------------------------------------------------------------------------ -- HpcCombine specifics data CombineFun = ADD | DIFF | SUB - deriving (Eq,Show, Read, Enum) + 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 + ADD -> (+) + 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] - ] +foldFuns :: [(String, CombineFun)] +foldFuns = [(show comb, comb) | comb <- [ADD .. SUB]] data PostFun = ID | INV | ZERO - deriving (Eq,Show, Read, Enum) + deriving (Eq, Show, Read, Enum) thePostFun :: PostFun -> Integer -> Integer -thePostFun ID x = x -thePostFun INV 0 = 1 -thePostFun INV _ = 0 +thePostFun ID x = x +thePostFun INV 0 = 1 +thePostFun INV _ = 0 thePostFun ZERO _ = 0 postFuns :: [(String, PostFun)] -postFuns = [ (show pos,pos) - | pos <- [ID .. ZERO] - ] - +postFuns = [(show pos, pos) | pos <- [ID .. ZERO]] data MergeFun = INTERSECTION | UNION - deriving (Eq,Show, Read, Enum) + 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 +theMergeFun UNION = Set.union mergeFuns :: [(String, MergeFun)] -mergeFuns = [ (show pos,pos) - | pos <- [INTERSECTION,UNION] - ] - +mergeFuns = [(show pos, pos) | pos <- [INTERSECTION, UNION]] diff --git a/src/HpcLexer.hs b/src/HpcLexer.hs index 5610b7a..2cee0fd 100644 --- a/src/HpcLexer.hs +++ b/src/HpcLexer.hs @@ -2,56 +2,57 @@ module HpcLexer where import Data.Char +------------------------------------------------------------------------------ + data Token - = ID String - | SYM Char - | INT Int - | STR String - | CAT String - deriving (Eq,Show) + = ID String + | SYM Char + | INT Int + | STR String + | CAT String + deriving (Eq, Show) initLexer :: String -> [Token] -initLexer str = [ t | (_,_,t) <- lexer str 1 1 ] +initLexer str = [t | (_, _, t) <- lexer str 1 1] -lexer :: String -> Int -> Int -> [(Int,Int,Token)] -lexer (c:cs) line column +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) + | 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 +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 +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 +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 +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) +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" +lexerCAT [] _ _ _ = error "lexer failure in CAT" test :: IO () test = do - t <- readFile "EXAMPLE.tc" - print (initLexer t) - + t <- readFile "EXAMPLE.tc" + print (initLexer t) diff --git a/src/HpcMain.hs b/src/HpcMain.hs index fe07047..53b288d 100644 --- a/src/HpcMain.hs +++ b/src/HpcMain.hs @@ -1,105 +1,113 @@ -{-# LANGUAGE ScopedTypeVariables, TupleSections #-} -module HpcMain ( main ) where --- (c) 2007 Andy Gill +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HpcMain (main) where +-- (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 ( showVersion ) -import System.Environment ( getArgs ) -import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) ) -import System.Console.GetOpt ( getOpt, ArgOrder(Permute) ) -import System.Directory (doesPathExist) +import Control.Monad +import Data.Bifunctor +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Version +import HpcCombine +import HpcDraft import HpcFlags - ( Plugin(..), - Flags, - default_flags, - default_final_flags, - command_usage ) -import HpcReport ( report_plugin ) -import HpcMarkup ( markup_plugin ) -import HpcCombine ( sum_plugin, combine_plugin, map_plugin ) -import HpcShowTix ( showtix_plugin ) -import HpcDraft ( draft_plugin ) -import HpcOverlay ( overlay_plugin ) -import Paths_hpc_bin ( version ) +import HpcMarkup +import HpcOverlay +import HpcReport +import HpcShowTix +import Paths_hpc_bin +import System.Console.GetOpt +import System.Directory +import System.Environment +import System.Exit + +------------------------------------------------------------------------------ helpList :: IO () helpList = do - putStrLn $ - "Usage: hpc COMMAND ...\n\n" <> - section "Commands" [help_plugin] <> - section "Reporting Coverage" [report_plugin, markup_plugin] <> - section "Processing Coverage files" [sum_plugin, combine_plugin, map_plugin] <> - section "Coverage Overlays" [overlay_plugin, draft_plugin] <> - section "Others" [showtix_plugin, version_plugin] <> - "" - 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" + putStrLn $ + "Usage: hpc COMMAND ...\n\n" + <> section "Commands" [helpPlugin] + <> section "Reporting Coverage" [reportPlugin, markupPlugin] + <> section "Processing Coverage files" [sumPlugin, combinePlugin, mapPlugin] + <> section "Coverage Overlays" [overlayPlugin, draftPlugin] + <> section "Others" [showtixPlugin, versionPlugin] + <> "" + 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" -- | Print the summaries of all plugins belonging to a given section. -section :: String -- ^ Name of the section. - -> [Plugin] -- ^ Plugins belonging to that section. - -> String +section :: + -- | Name of the section. + String -> + -- | Plugins belonging to that section. + [Plugin] -> + String section msg plugins = msg <> ":\n" <> unlines summaries where - summaries = [ take 14 (" " <> name plugin <> repeat ' ') <> summary plugin | plugin <- plugins ] + summaries = [take 14 (" " <> name plugin <> repeat ' ') <> summary plugin | plugin <- plugins] main :: IO () main = do - args <- getArgs - dispatch args + args <- getArgs + dispatch args -- | The main dispatch function. It either accepts a valid command followed by a list of its arguments, -- or a list of response files of the form '@filename'. dispatch :: [String] -> IO () dispatch [] = do - helpList - exitWith ExitSuccess -dispatch (txt:args0) = do - case lookup txt hooks' of - Just plugin -> dispatchOnPlugin plugin args0 - _ -> case getResponseFileName txt of - Nothing -> dispatchOnPlugin 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 - dispatchOnResponseFiles (firstResponseFileName :| responseFileNames') + helpList + exitSuccess +dispatch (txt : args0) = do + case lookup txt hooks' of + Just plugin -> do + dispatchOnPlugin plugin args0 + _ -> case getResponseFileName txt of + Nothing -> do + dispatchOnPlugin helpPlugin (txt : args0) + Just firstResponseFileName -> do + let (responseFileNames', nonResponseFileNames) = partitionFileNames args0 + -- if arguments are combination of Response Files and non-Response Files, exit with error + unless (null nonResponseFileNames) $ do + 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 + dispatchOnResponseFiles (firstResponseFileName :| responseFileNames') 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 + 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) -- | Dispatch on a given list of response files. @@ -107,14 +115,14 @@ dispatchOnResponseFiles :: NonEmpty FilePath -> IO () dispatchOnResponseFiles fps = do forM_ fps $ \responseFileName -> do exists <- doesPathExist responseFileName - when (not exists) $ do + unless exists $ do putStrLn $ "Response File '" <> responseFileName <> "' does not exist" exitFailure -- read all Response Files responseFileNamesAndText :: NonEmpty (FilePath, String) <- forM fps $ \responseFileName -> - fmap (responseFileName, ) (readFile 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 @@ -126,8 +134,12 @@ dispatchOnResponseFiles fps = do -- It is important than a Response File cannot specify another Response File; -- this is prevented Nothing -> do - putStrLn $ "Response File '" <> responseFileName <> - "' command '" <> responseFileCommand <> "' invalid" + putStrLn $ + "Response File '" + <> responseFileName + <> "' command '" + <> responseFileCommand + <> "' invalid" exitFailure Just plugin -> do putStrLn $ "Response File '" <> responseFileName <> "':" @@ -137,75 +149,69 @@ dispatchOnResponseFiles fps = do dispatchOnPlugin :: Plugin -> [String] -> IO () dispatchOnPlugin plugin args = case getOpt Permute (options plugin []) args of - (_,_,errs) | not (null errs) -> do + (_, _, errs) | not (null errs) -> do putStrLn "hpc failed:" - sequence_ [ putStr (" " <> err) | err <- errs ] - putStrLn $ "\n" - command_usage plugin + sequence_ [putStr (" " <> err) | err <- errs] + putStrLn "\n" + commandUsage plugin exitFailure - (o,ns,_) -> do - let flags = final_flags plugin - . foldr (.) id o - $ init_flags plugin + (o, ns, _) -> do + let flags = final_flags plugin (foldr ($) (init_flags plugin) o) implementation plugin flags ns ------------------------------------------------------------------------------- - hooks :: [Plugin] -hooks = [ help_plugin - , report_plugin - , markup_plugin - , sum_plugin - , combine_plugin - , map_plugin - , showtix_plugin - , overlay_plugin - , draft_plugin - , version_plugin - ] +hooks = + [ helpPlugin, + reportPlugin, + markupPlugin, + sumPlugin, + combinePlugin, + mapPlugin, + showtixPlugin, + overlayPlugin, + draftPlugin, + versionPlugin + ] 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 = id - , 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 - ------------------------------------------------------------------------------- - -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) - - ------------------------------------------------------------------------------- +hooks' = [(name hook, hook) | hook <- hooks] + +helpPlugin :: Plugin +helpPlugin = + Plugin + { name = "help", + usage = "[<HPC_COMMAND>]", + summary = "Display help for hpc or a single command", + options = id, + implementation = helpMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } + +helpMain :: Flags -> [String] -> IO () +helpMain _ [] = do + helpList + exitSuccess +helpMain _ (sub_txt : _) = do + case lookup sub_txt hooks' of + Nothing -> do + putStrLn $ "no such HPC command: " <> sub_txt + exitFailure + Just plugin' -> do + commandUsage plugin' + exitSuccess + +versionPlugin :: Plugin +versionPlugin = + Plugin + { name = "version", + usage = "", + summary = "Display version for hpc", + options = id, + implementation = versionMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } + +versionMain :: Flags -> [String] -> IO () +versionMain _ _ = putStrLn ("hpc tools, version " ++ showVersion version) diff --git a/src/HpcMarkup.hs b/src/HpcMarkup.hs index d156f26..8925b68 100644 --- a/src/HpcMarkup.hs +++ b/src/HpcMarkup.hs @@ -3,139 +3,146 @@ -- 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) +module HpcMarkup (markupPlugin) where +import Control.Monad +import Data.Array +import Data.List +import Data.Maybe +import Data.Semigroup as Semi +import qualified Data.Set as Set 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 +import Trace.Hpc.Mix +import Trace.Hpc.Tix +import Trace.Hpc.Util ------------------------------------------------------------------------------ -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 - } +markupOptions :: FlagOptSeq +markupOptions = + excludeOpt + . includeOpt + . srcDirOpt + . hpcDirOpt + . resetHpcDirsOpt + . funTotalsOpt + . altHighlightOpt + . destDirOpt + . verbosityOpt + +markupPlugin :: Plugin +markupPlugin = + Plugin + { name = "markup", + usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]", + options = markupOptions, + summary = "Markup Haskell source with program coverage", + implementation = markupMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } ------------------------------------------------------------------------------ -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 +markupMain :: Flags -> [String] -> IO () +markupMain 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 + Nothing -> hpcError markupPlugin $ "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) - ] + 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" + 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") + 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" + "<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)) +markupMain _ [] = + hpcError markupPlugin "no .tix file or executable name specified" -- Add characters to the left of a string until it is at least as -- large as requested. @@ -143,17 +150,11 @@ 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) + 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 @@ -161,230 +162,248 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix) let arr_tix :: Array Int Integer - arr_tix = listArray (0,length (tixModuleTixs tix) - 1) - $ tixModuleTixs tix + 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 + let 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 + ($) + mempty + ( [ \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 + ] + ) -- add prefix to modName argument - content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath + content <- readFileFromPath (hpcError markupPlugin) 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 addLines = unlines . zipWith addLine [1 :: Int ..] . lines let fileName = modName0 <.> "hs" <.> "html" - unless (verbosity flags < Normal) $ - putStrLn $ "Writing: " ++ fileName + + unless (verbosity flags < Normal) $ do + 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) + 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) + 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 + = NotTicked + | TickedOnlyTrue + | TickedOnlyFalse + | IsTicked + | TopLevelDecl + Bool -- display entry totals + Integer + deriving (Eq, Show) + +markup :: + -- | tabStop + Int -> + [(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 - + 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 +-- addMarkup tabStop cs loc os ticks -- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os - ---addMarkup tabStop cs loc os@(_:_) ticks +-- 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 = +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 = +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 + ((_, 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 - (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) + 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 + | c0 == '\n' && os /= [] = + 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 + | c0 == '\t' = + expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks + | otherwise = + 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 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 - - +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>" @@ -392,94 +411,109 @@ closeTick = "</span>" openTopDecl :: String openTopDecl = "<span class=\"decl\">" -downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)] -downToTopLevel ((_,TopLevelDecl {}):_) = [] -downToTopLevel (o : os) = o : downToTopLevel os -downToTopLevel [] = [] - +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 +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) - + { 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" +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" + "<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>" + "<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) + (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 - } + 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" +red, green, yellow :: String +red = "#f20913" +green = "#60de51" yellow = "yellow" diff --git a/src/HpcOverlay.hs b/src/HpcOverlay.hs index 44ac6d0..db9046b 100644 --- a/src/HpcOverlay.hs +++ b/src/HpcOverlay.hs @@ -1,157 +1,166 @@ module HpcOverlay where +import qualified Data.Map as Map +import Data.Tree import HpcFlags import HpcParser import HpcUtils -import Trace.Hpc.Tix import Trace.Hpc.Mix +import Trace.Hpc.Tix 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 +------------------------------------------------------------------------------ + +overlayOptions :: FlagOptSeq +overlayOptions = + srcDirOpt + . hpcDirOpt + . resetHpcDirsOpt + . outputOpt + . verbosityOpt + +overlayPlugin :: Plugin +overlayPlugin = + Plugin + { name = "overlay", + usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]", + options = overlayOptions, + summary = "Generate a .tix file from an overlay file", + implementation = overlayMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } + +overlayMain :: Flags -> [String] -> IO () +overlayMain _ [] = hpcError overlayPlugin "no overlay file specified" +overlayMain flags files = do specs <- mapM hpcParser files let (Spec globals modules) = concatSpec specs - let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ] + 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 - ] + sequence + [ do + mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu) + content <- readFileFromPath (hpcError overlayPlugin) origFile (srcDirs flags) + processModule modu content mix mod_spec globals + | (modu, mod_spec) <- Map.toList modules1 + ] - - let tix = Tix $ mod_info + let tix = Tix mod_info case outputFile flags of - "-" -> putStrLn (show tix) + "-" -> print 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 :: + -- | module name + String -> + -- | module contents + String -> + -- | mix entry for this module + Mix -> + -- | local ticks + [Tick] -> + -- | global ticks + [ExprTick] -> + 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' + 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 _ 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 + 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 [] []) - - +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) +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 +addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a], [a])] +addParentToList path = map (addParentToTree path) diff --git a/src/HpcParser.y b/src/HpcParser.y index bff9530..ea66089 100644 --- a/src/HpcParser.y +++ b/src/HpcParser.y @@ -1,4 +1,4 @@ -{ +{ module HpcParser where import HpcLexer @@ -34,7 +34,7 @@ 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 []) } @@ -42,18 +42,18 @@ Module : MODULE string '{' TopTicks '}' 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 } - + | { id } + Tick :: { ExprTick } Tick : TICK optString optQual optCat ';' { TickExpression False $2 $3 $4 } @@ -61,7 +61,7 @@ Tick : TICK optString optQual optCat ';' optString :: { Maybe String } optString : string { Just $1 } | { Nothing } - + optQual :: { Maybe Qualifier } optQual : ON LINE int { Just (OnLine $3) } | AT POSITION int ':' int '-' int ':' int @@ -73,10 +73,10 @@ optCat : cat { Just $1 } { type L a = [a] -> [a] - + type ModuleName = String -data Spec +data Spec = Spec [ExprTick] [(ModuleName,[Tick])] deriving (Show) @@ -92,15 +92,14 @@ data Tick data Qualifier = OnLine Int | AtPosition Int Int Int Int - deriving (Show) - + deriving (Show) hpcParser :: String -> IO Spec hpcParser filename = do txt <- readFile filename let tokens = initLexer txt - return $ parser tokens + return $ parser tokens happyError e = error $ show (take 10 e) } diff --git a/src/HpcReport.hs b/src/HpcReport.hs index 2761275..2697ea5 100644 --- a/src/HpcReport.hs +++ b/src/HpcReport.hs @@ -3,154 +3,190 @@ -- Colin Runciman and Andy Gill, June 2006 --------------------------------------------------------- -module HpcReport (report_plugin) where +module HpcReport (reportPlugin) where -import Prelude hiding (exp) -import Data.List(sort,intersperse,sortBy) +import Control.Monad hiding (guard) +import Data.Function +import Data.List +import qualified Data.Set as Set import HpcFlags import Trace.Hpc.Mix import Trace.Hpc.Tix -import Control.Monad hiding (guard) -import qualified Data.Set as Set -import Data.Function (on) +import Prelude hiding (exp) + +------------------------------------------------------------------------------ notExpecting :: String -> a -notExpecting s = error ("not expecting "++s) +notExpecting s = error ("not expecting " ++ s) data BoxTixCounts = BT {boxCount, tixCount :: !Int} instance Semigroup BoxTixCounts where - bt1 <> bt2 = BT - { boxCount = ((+) `on` boxCount) bt1 bt2 - , tixCount = ((+) `on` tixCount) bt1 bt2 - } + bt1 <> bt2 = + BT + { boxCount = ((+) `on` boxCount) bt1 bt2, + tixCount = ((+) `on` tixCount) bt1 bt2 + } + instance Monoid BoxTixCounts where - mempty = BT - { boxCount=0 - , tixCount=0 - } + mempty = BT {boxCount = 0, tixCount = 0} 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++")" +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 + 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} +data BinBoxTixCounts = BBT + { binBoxCount :: !Int, + onlyTrueTixCount :: !Int, + onlyFalseTixCount :: !Int, + bothTixCount :: !Int + } instance Semigroup BinBoxTixCounts where - bbt1 <> bbt2 = BBT - { binBoxCount = ((+) `on` binBoxCount) bbt1 bbt2 - , onlyTrueTixCount = ((+) `on` onlyTrueTixCount) bbt1 bbt2 - , onlyFalseTixCount = ((+) `on` onlyFalseTixCount) bbt1 bbt2 - , bothTixCount = ((+) `on` bothTixCount) bbt1 bbt2 - } + bbt1 <> bbt2 = + BBT + { binBoxCount = ((+) `on` binBoxCount) bbt1 bbt2, + onlyTrueTixCount = ((+) `on` onlyTrueTixCount) bbt1 bbt2, + onlyFalseTixCount = ((+) `on` onlyFalseTixCount) bbt1 bbt2, + bothTixCount = ((+) `on` bothTixCount) bbt1 bbt2 + } + instance Monoid BinBoxTixCounts where - mempty = BBT - { binBoxCount=0 - , onlyTrueTixCount=0 - , onlyFalseTixCount=0 - , bothTixCount=0 - } + mempty = + BBT + { binBoxCount = 0, + onlyTrueTixCount = 0, + onlyFalseTixCount = 0, + bothTixCount = 0 + } 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 "" + 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 "" + 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]]} +data ModInfo = MI + { exp, alt, top, loc :: !BoxTixCounts, + guard, cond, qual :: !BinBoxTixCounts, + decPaths :: [[String]] + } instance Semigroup ModInfo where - mi1 <> mi2 = MI - { exp = ((<>) `on` exp) mi1 mi2 - , alt = ((<>) `on` alt) mi1 mi2 - , top = ((<>) `on` top) mi1 mi2 - , loc = ((<>) `on` loc) mi1 mi2 - , guard = ((<>) `on` guard) mi1 mi2 - , cond = ((<>) `on` cond) mi1 mi2 - , qual = ((<>) `on` qual) mi1 mi2 - , decPaths = ((<>) `on` decPaths) mi1 mi2 - } + mi1 <> mi2 = + MI + { exp = ((<>) `on` exp) mi1 mi2, + alt = ((<>) `on` alt) mi1 mi2, + top = ((<>) `on` top) mi1 mi2, + loc = ((<>) `on` loc) mi1 mi2, + guard = ((<>) `on` guard) mi1 mi2, + cond = ((<>) `on` cond) mi1 mi2, + qual = ((<>) `on` qual) mi1 mi2, + decPaths = ((<>) `on` decPaths) mi1 mi2 + } + instance Monoid ModInfo where - mempty = MI - { exp=mempty - , alt=mempty - , top=mempty - , loc=mempty - , guard=mempty - , cond=mempty - , qual=mempty - , decPaths=mempty - } + mempty = + MI + { exp = mempty, + alt = mempty, + top = mempty, + loc = mempty, + guard = mempty, + cond = mempty, + qual = mempty, + decPaths = mempty + } allBinCounts :: ModInfo -> BinBoxTixCounts allBinCounts mi = - BBT { binBoxCount = sumAll binBoxCount - , onlyTrueTixCount = sumAll onlyTrueTixCount - , onlyFalseTixCount = sumAll onlyFalseTixCount - , bothTixCount = sumAll bothTixCount } + 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) + sumAll f = f (guard mi) + f (cond mi) + f (qual mi) -accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo +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)} - 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 + 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 ((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) } + 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 @@ -167,19 +203,20 @@ modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix) return (q (accumCounts (zip (map snd mes) tickCounts) mempty)) where - q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)} - else mi + 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++">-----") + then putStrLn $ " <module name = " ++ show moduleName ++ ">" + else putStrLn ("-----<module " ++ moduleName ++ ">-----") printModInfo hpcflags mi - if xmlOutput hpcflags - then putStrLn $ " </module>" - else return () + when (xmlOutput hpcflags) $ do + putStrLn " </module>" printModInfo :: Flags -> ModInfo -> IO () printModInfo hpcflags mi | xmlOutput hpcflags = do @@ -194,9 +231,9 @@ printModInfo hpcflags mi | xmlOutput hpcflags = do 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 (" " ++ 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)) @@ -208,83 +245,92 @@ modDecList hpcflags mi0 = 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 + someDecsUnused mi = + tixCount (top mi) < boxCount (top mi) + || tixCount (loc mi) < boxCount (loc mi) + showDecPath dp = + putStrLn (" " ++ intercalate "." dp) + +reportPlugin :: Plugin +reportPlugin = + Plugin + { name = "report", + usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]", + options = reportFlags, + summary = "Output textual report about program coverage", + implementation = reportMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } + +reportMain :: Flags -> [String] -> IO () +reportMain 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 hpcflags1 progName $ + sortBy (\mod1 mod2 -> tixModuleName mod1 `compare` tixModuleName mod2) $ + [tix' | tix'@(TixModule m _ _ _) <- tickCounts, allowModule hpcflags1 m] + Nothing -> hpcError reportPlugin $ "unable to find tix file for:" ++ progName +reportMain _ [] = + hpcError reportPlugin "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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" putStrLn $ "<coverage name=" ++ show progName ++ ">" - if perModule hpcflags - then mapM_ (modReport hpcflags) modTcs - else return () + when (perModule hpcflags) $ do + mapM_ (modReport hpcflags) modTcs mis <- mapM (modInfo hpcflags True) modTcs - putStrLn $ " <summary>" + putStrLn " <summary>" printModInfo hpcflags (mconcat mis) - putStrLn $ " </summary>" - putStrLn $ "</coverage>" + 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 (mconcat mis) + if perModule hpcflags + then mapM_ (modReport hpcflags) modTcs + else do + mis <- mapM (modInfo hpcflags True) modTcs + printModInfo hpcflags (mconcat mis) -element :: String -> [(String,String)] -> IO () -element tag attrs = putStrLn $ - " <" ++ tag ++ " " - ++ unwords [ x ++ "=" ++ show y - | (x,y) <- attrs - ] ++ "/>" +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)] +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))] +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 +reportFlags :: FlagOptSeq +reportFlags = + perModuleOpt + . decListOpt + . excludeOpt + . includeOpt + . srcDirOpt + . hpcDirOpt + . resetHpcDirsOpt + . xmlOutputOpt + . verbosityOpt diff --git a/src/HpcShowTix.hs b/src/HpcShowTix.hs index 551ed88..9b91988 100644 --- a/src/HpcShowTix.hs +++ b/src/HpcShowTix.hs @@ -1,63 +1,73 @@ -module HpcShowTix (showtix_plugin) where +module HpcShowTix (showtixPlugin) where +import qualified Data.Set as Set +import HpcFlags import Trace.Hpc.Mix import Trace.Hpc.Tix -import HpcFlags +------------------------------------------------------------------------------ -import qualified Data.Set as Set +showtixOptions :: FlagOptSeq +showtixOptions = + excludeOpt + . includeOpt + . srcDirOpt + . hpcDirOpt + . resetHpcDirsOpt + . outputOpt + . verbosityOpt -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 } +showtixPlugin :: Plugin +showtixPlugin = + Plugin + { name = "show", + usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]", + options = showtixOptions, + summary = "Show .tix file in readable, verbose format", + implementation = showtixMain, + init_flags = defaultFlags, + final_flags = defaultFinalFlags + } + +showtixMain :: Flags -> [String] -> IO () +showtixMain _ [] = hpcError showtixPlugin "no .tix file or executable name specified" +showtixMain 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 + Nothing -> + hpcError showtixPlugin $ "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 () + tixs_mixs <- + sequence + [ do + mix <- readMixWithFlags hpcflags1 (Right tix) + return (tix, mix) + | tix <- tixs, + allowModule hpcflags1 (tixModuleName tix) + ] + + let rjust n str = replicate (n - length str) ' ' ++ str + let ljust n str = str ++ replicate (n - length str) ' ' + + 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 + ] diff --git a/src/HpcUtils.hs b/src/HpcUtils.hs index da62f4a..d4cee8d 100644 --- a/src/HpcUtils.hs +++ b/src/HpcUtils.hs @@ -1,35 +1,47 @@ module HpcUtils where -import Trace.Hpc.Util (catchIO, HpcPos, fromHpcPos, readFileUtf8) import qualified Data.Map as Map import System.FilePath +import Trace.Hpc.Util -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) [] +------------------------------------------------------------------------------ +-- Spec: dropWhileEndLE p = reverse . dropWhile p . reverse -- turns \n into ' ' --- | grab's the text behind a HpcPos; -grabHpcPos :: Map.Map Int String -> HpcPos -> String -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 srcspan - lns = map (\ n -> case Map.lookup n hsMap of - Just ln -> ln - Nothing -> error $ "bad line number : " ++ show n - ) [l1..l2] +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x : r) [] +-- | grab's the text behind a HpcPos; +grabHpcPos :: Map.Map Int String -> HpcPos -> String +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 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 _ 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) + readTheFile [] = + err $ + "could not find " + ++ show filename + ++ " in path " + ++ show path0 + readTheFile (dir : dirs) = + catchIO + (readFileUtf8 (dir </> filename)) + (\_ -> readTheFile dirs) -- GitLab