From: andy@galois.com Date: Thu, 12 Jul 2007 19:42:00 +0000 (+0000) Subject: Adding draft and show to hpc X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a966047ca5c407f336a633d716d3d7b5ed29d231 Adding draft and show to hpc we now have hpc draft This drafts up a candidate overlay for 100% coverage. and hpc show This show verbose details about a tix file; mainly for debugging. --- diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs index d567a0f..5db2b30 100644 --- a/utils/hpc/Hpc.hs +++ b/utils/hpc/Hpc.hs @@ -10,6 +10,8 @@ import System.Console.GetOpt import HpcReport import HpcMarkup import HpcCombine +import HpcShowTix +import HpcDraft helpList :: IO () helpList = @@ -18,16 +20,18 @@ helpList = section "Commands" help ++ section "Reporting Coverage" reporting ++ section "Processing Coverage files" processing ++ + section "Coverage Overlays" overlays ++ section "Others" other ++ "" where help = ["help"] reporting = ["report","markup"] + overlays = ["overlay","draft"] processing = ["combine"] other = [ name hook | hook <- hooks , name hook `notElem` - (concat [help,reporting,processing]) + (concat [help,reporting,processing,overlays]) ] section :: String -> [String] -> String @@ -72,6 +76,8 @@ hooks = [ help_plugin , report_plugin , markup_plugin , combine_plugin + , showtix_plugin + , draft_plugin , version_plugin ] @@ -116,4 +122,4 @@ version_plugin = Plugin { name = "version" version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev" ------------------------------------------------------------------------------- +------------------------------------------------------------------------------ \ No newline at end of file diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs new file mode 100644 index 0000000..bf67213 --- /dev/null +++ b/utils/hpc/HpcDraft.hs @@ -0,0 +1,145 @@ +module HpcDraft (draft_plugin) where + +import Trace.Hpc.Tix +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import HpcFlags + +import Control.Monad +import qualified HpcSet as Set +import qualified HpcMap as Map +import System.Environment +import HpcUtils +import Data.Tree + +------------------------------------------------------------------------------ +draft_options = + [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,outputOpt ] + +draft_plugin = Plugin { name = "draft" + , usage = "[OPTION] .. " + , options = draft_options + , summary = "Generate draft overlay that provides 100% coverage" + , implementation = draft_main + , init_flags = default_flags + , final_flags = default_final_flags + } + +------------------------------------------------------------------------------ + +draft_main :: Flags -> [String] -> IO () +draft_main hpcflags (progName:mods) = do + let hpcflags1 = hpcflags + { includeMods = Set.fromList mods + `Set.union` + includeMods hpcflags } + let prog = getTixFileName $ progName + tix <- readTix prog + case tix of + Just (Tix tickCounts) -> do + outs <- sequence + [ makeDraft hpcflags1 tixModule + | tixModule@(TixModule m _ _ _) <- tickCounts + , allowModule hpcflags1 m + ] + case outputFile hpcflags1 of + "-" -> putStrLn (unlines outs) + out -> writeFile out (unlines outs) + Nothing -> hpcError draft_plugin $ "unable to find tix file for:" ++ progName + + +makeDraft :: Flags -> TixModule -> IO String +makeDraft hpcflags tix = do + let mod = tixModuleName tix + hash = tixModuleHash tix + tixs = tixModuleTixs tix + + mix@(Mix filepath timestamp hash tabstop entries) <- readMix (hpcDirs hpcflags) mod + + let forest = createMixEntryDom + [ (span,(box,v > 0)) + | ((span,box),v) <- zip entries tixs + ] + +-- let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span) +-- putStrLn $ drawForest $ map (fmap show) $ forest + + let non_ticked = findNotTickedFromList forest + + hs <- readFileFromPath filepath (hsDirs hpcflags) + + let hsMap :: Map.Map Int String + hsMap = Map.fromList (zip [1..] $ lines hs) + + let quoteString = show + + let firstLine pos = case fromHpcPos pos of + (ln,_,_,_) -> ln + + + let showPleaseTick :: Int -> PleaseTick -> String + showPleaseTick d (TickFun str pos) = + spaces d ++ "tick function \"" ++ head str ++ "\" " + ++ "on line " ++ show (firstLine pos) ++ ";" + showPleaseTick d (TickExp pos) = + spaces d ++ "tick expression " + ++ 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] pos pleases) = + spaces d ++ "function \"" ++ str ++ "\" {\n" ++ + showPleaseTicks (d + 2) pleases ++ + spaces d ++ "}" + + showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases) + + spaces d = take d (repeat ' ') + + return $ "module " ++ show (fixPackageSuffix mod) ++ " {\n" ++ + showPleaseTicks 2 non_ticked ++ "}" + +fixPackageSuffix :: String -> String +fixPackageSuffix mod = case span (/= '/') mod of + (before,'/':after) -> before ++ ":" ++ after + _ -> mod + +data PleaseTick + = TickFun [String] HpcPos + | TickExp HpcPos + | TickInside [String] HpcPos [PleaseTick] + deriving Show + +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):others) children) + = mkTickInside nm pos (findNotTickedFromList children) [] +findNotTickedFromTree (Node (pos,_:others) children) = + findNotTickedFromTree (Node (pos,others) children) +findNotTickedFromTree (Node (pos,[]) children) = findNotTickedFromList children + +findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick] +findNotTickedFromList = concatMap findNotTickedFromTree + +readFileFromPath :: String -> [String] -> IO String +readFileFromPath filename@('/':_) _ = readFile filename +readFileFromPath filename path0 = readTheFile path0 + where + readTheFile :: [String] -> IO String + readTheFile [] = error $ "could not find " ++ show filename + ++ " in path " ++ show path0 + readTheFile (dir:dirs) = + catch (do str <- readFile (dir ++ "/" ++ filename) + return str) + (\ _ -> readTheFile dirs) diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs index 38abe63..eb9a197 100644 --- a/utils/hpc/HpcFlags.hs +++ b/utils/hpc/HpcFlags.hs @@ -147,8 +147,8 @@ allowModule flags full_mod where -- pkg name always ends with '/', main (pkg_name,mod_name) = - case span (/= ':') full_mod of - (p,':':m) -> (p ++ ":",m) + case span (/= '/') full_mod of + (p,'/':m) -> (p ++ ":",m) (m,[]) -> (":",m) _ -> error "impossible case in allowModule" @@ -156,6 +156,8 @@ filterTix :: Flags -> Tix -> Tix filterTix flags (Tix tixs) = Tix $ filter (allowModule flags . tixModuleName) tixs + + ------------------------------------------------------------------------------ -- HpcCombine specifics diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs new file mode 100644 index 0000000..79c9fa3 --- /dev/null +++ b/utils/hpc/HpcShowTix.hs @@ -0,0 +1,60 @@ +module HpcShowTix (showtix_plugin) where + +import Trace.Hpc.Mix +import Trace.Hpc.Tix +import Trace.Hpc.Util + +import HpcFlags + +import qualified Data.Set as Set + +showtix_options = + [ excludeOpt,includeOpt,hpcDirOpt + , outputOpt + ] + +showtix_plugin = Plugin { name = "show" + , usage = "[OPTION] .. [ [ ..]]" + , 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 [] = hpcError showtix_plugin $ "no .tix file or executable name specified" +showtix_main flags (prog:modNames) = do + let hpcflags1 = flags + { includeMods = Set.fromList modNames + `Set.union` + includeMods flags } + + optTixs <- readTix (getTixFileName prog) + case optTixs of + Nothing -> hpcError showtix_plugin $ "could not read .tix file : " ++ prog + Just (Tix tixs) -> do + let modules = map tixModuleName tixs + + mixs <- sequence + [ readMix (hpcDirs hpcflags1) modName -- hard wired to .hpc for now + | modName <- modules + , allowModule hpcflags1 modName + ] + + 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 hash _ tixs + , Mix _file _timestamp _hash _tab entries + ) <- zip tixs mixs + ] + + return () + \ No newline at end of file diff --git a/utils/hpc/HpcUtils.hs b/utils/hpc/HpcUtils.hs new file mode 100644 index 0000000..b679a37 --- /dev/null +++ b/utils/hpc/HpcUtils.hs @@ -0,0 +1,20 @@ +module HpcUtils where + +import Trace.Hpc.Util +import qualified HpcMap as Map + +-- turns \n into ' ' +-- | grab's the text behind a HpcPos; +grabHpcPos :: Map.Map Int String -> HpcPos -> String +grabHpcPos hsMap span = + case lns of + [ln] -> (take ((c2 - c1) + 1) $ drop (c1 - 1) ln) + _ -> let lns1 = drop (c1 -1) (head lns) : tail lns + lns2 = init lns1 ++ [take (c2 + 1) (last lns1) ] + in foldl1 (\ xs ys -> xs ++ "\n" ++ ys) lns2 + where (l1,c1,l2,c2) = fromHpcPos span + lns = map (\ n -> case Map.lookup n hsMap of + Just ln -> ln + Nothing -> error $ "bad line number : " ++ show n + ) [l1..l2] +