Commit a966047c authored by andy@galois.com's avatar andy@galois.com
Browse files

Adding draft and show to hpc

we now have 
  
  hpc draft <TIX_FILE>

This drafts up a candidate overlay for 100% coverage.
 
and

  hpc show  <TIX_FILE>

This show verbose details about a tix file; mainly for debugging.
parent 41ac7eb3
......@@ -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
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] .. <TIX_FILE>"
, options = draft_options
, summary = "Generate draft overlay that provides 100% coverage"
, implementation = draft_main
, init_flags = default_flags
, final_flags = default_final_flags
}
------------------------------------------------------------------------------
draft_main :: Flags -> [String] -> IO ()
draft_main 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)
......@@ -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
......
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] .. <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 [] = 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
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]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment