Commit 4799dfb3 authored by andy@galois.com's avatar andy@galois.com

hpc-tools: improving flag processing and help messages, small bug fixes.

parent 30091f98
-- (c) 2007 Andy Gill
-- Main driver for Hpc
import Trace.Hpc.Tix
import HpcFlags
import System.Environment
import System.Exit
......@@ -11,6 +12,7 @@ import HpcMarkup
import HpcCombine
import HpcShowTix
import HpcDraft
import HpcOverlay
helpList :: IO ()
helpList =
......@@ -48,11 +50,11 @@ dispatch [] = do
exitWith ExitSuccess
dispatch (txt:args) = do
case lookup txt hooks' of
Just plugin -> parse plugin
_ -> parse help_plugin
Just plugin -> parse plugin args
_ -> parse help_plugin (txt:args)
where
parse plugin =
case getOpt Permute (options plugin) args of
parse plugin args =
case getOpt Permute (options plugin []) args of
(_,_,errs) | not (null errs)
-> do putStrLn "hpc failed:"
sequence [ putStr (" " ++ err)
......@@ -62,7 +64,8 @@ dispatch (txt:args) = do
command_usage plugin
exitFailure
(o,ns,_) -> do
let flags = foldr (.) (final_flags plugin) o
let flags = final_flags plugin
$ foldr (.) id o
$ init_flags plugin
implementation plugin flags ns
main = do
......@@ -76,6 +79,7 @@ hooks = [ help_plugin
, markup_plugin
, combine_plugin
, showtix_plugin
, overlay_plugin
, draft_plugin
, version_plugin
]
......@@ -105,14 +109,14 @@ help_main flags (sub_txt:_) = do
command_usage plugin'
exitWith ExitSuccess
help_options = []
help_options = id
------------------------------------------------------------------------------
version_plugin = Plugin { name = "version"
, usage = ""
, summary = "Display version for hpc"
, options = []
, options = id
, implementation = version_main
, init_flags = default_flags
, final_flags = default_final_flags
......@@ -121,4 +125,4 @@ version_plugin = Plugin { name = "version"
version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev"
------------------------------------------------------------------------------
------------------------------------------------------------------------------
\ No newline at end of file
......@@ -13,10 +13,16 @@ import HpcFlags
import Control.Monad
import qualified HpcSet as Set
import qualified HpcMap as Map
import System.Environment
------------------------------------------------------------------------------
combine_options =
[ excludeOpt,includeOpt,outputOpt,combineFunOpt, combineFunOptInfo, postInvertOpt ]
combine_options
= excludeOpt
. includeOpt
. outputOpt
. combineFunOpt
. combineFunOptInfo
. postInvertOpt
combine_plugin = Plugin { name = "combine"
, usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
......
......@@ -9,12 +9,17 @@ 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_options
= excludeOpt
. includeOpt
. srcDirOpt
. hpcDirOpt
. outputOpt
draft_plugin = Plugin { name = "draft"
, usage = "[OPTION] .. <TIX_FILE>"
......@@ -54,7 +59,7 @@ makeDraft hpcflags tix = do
hash = tixModuleHash tix
tixs = tixModuleTixs tix
mix@(Mix filepath timestamp hash tabstop entries) <- readMix (hpcDirs hpcflags) mod
mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags mod
let forest = createMixEntryDom
[ (span,(box,v > 0))
......@@ -66,7 +71,7 @@ makeDraft hpcflags tix = do
let non_ticked = findNotTickedFromList forest
hs <- readFileFromPath filepath (hsDirs hpcflags)
hs <- readFileFromPath filepath (srcDirs hpcflags)
let hsMap :: Map.Map Int String
hsMap = Map.fromList (zip [1..] $ lines hs)
......@@ -79,10 +84,10 @@ makeDraft hpcflags tix = do
let showPleaseTick :: Int -> PleaseTick -> String
showPleaseTick d (TickFun str pos) =
spaces d ++ "tick function \"" ++ head str ++ "\" "
spaces d ++ "tick function \"" ++ last str ++ "\" "
++ "on line " ++ show (firstLine pos) ++ ";"
showPleaseTick d (TickExp pos) =
spaces d ++ "tick expression "
spaces d ++ "tick "
++ if '\n' `elem` txt
then "at position " ++ show pos ++ ";"
else quoteString txt ++ " " ++ "on line " ++ show (firstLine pos) ++ ";"
......@@ -91,7 +96,7 @@ makeDraft hpcflags tix = do
txt = grabHpcPos hsMap pos
showPleaseTick d (TickInside [str] pos pleases) =
spaces d ++ "function \"" ++ str ++ "\" {\n" ++
spaces d ++ "inside \"" ++ str ++ "\" {\n" ++
showPleaseTicks (d + 2) pleases ++
spaces d ++ "}"
......
......@@ -3,17 +3,19 @@
module HpcFlags where
import System.Console.GetOpt
import Data.Maybe ( fromMaybe )
import qualified HpcSet as Set
import Data.Char
import Trace.Hpc.Tix
import Trace.Hpc.Mix
import System.Exit
data Flags = Flags
{ outputFile :: String
, includeMods :: Set.Set String
, excludeMods :: Set.Set String
, hsDirs :: [String]
, hpcDirs :: [String]
, hpcDir :: String
, srcDirs :: [String]
, destDir :: String
, perModule :: Bool
......@@ -31,8 +33,8 @@ default_flags = Flags
{ outputFile = "-"
, includeMods = Set.empty
, excludeMods = Set.empty
, hpcDirs = []
, hsDirs = []
, hpcDir = ".hpc"
, srcDirs = []
, destDir = "."
, perModule = False
......@@ -50,37 +52,45 @@ default_flags = Flags
-- depends on if specific flags we used.
default_final_flags flags = flags
{ hpcDirs = if null (hpcDirs flags)
then [".hpc"]
else hpcDirs flags
, hsDirs = if null (hsDirs flags)
{ srcDirs = if null (srcDirs flags)
then ["."]
else hsDirs flags
else srcDirs flags
}
noArg :: String -> String -> (Flags -> Flags) -> OptDescr (Flags -> Flags)
noArg flag detail fn = Option [] [flag] (NoArg $ fn) detail
type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
anArg :: String -> String -> String -> (String -> Flags -> Flags) -> OptDescr (Flags -> Flags)
anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail
noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
infoArg :: String -> OptDescr (Flags -> Flags)
infoArg info = Option [] [] (NoArg $ id) info
anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
infoArg :: String -> FlagOptSeq
infoArg info = (:) $ Option [] [] (NoArg $ id) info
includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]" $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
hpcDirOpt = anArg "hpcdir" "path to .mix files (default .hpc)" "DIR"
$ \ a f -> f { hpcDirs = hpcDirs f ++ [a] }
hsDirOpt = anArg "hsdir" "path to .hs files (default .)" "DIR"
$ \ a f -> f { hsDirs = hsDirs f ++ [a] }
destDirOpt = anArg "destdir" "path to write output to" "DIR"
$ \ a f -> f { destDir = a }
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" "sub-directory that contains .mix files" "DIR"
(\ a f -> f { hpcDir = a })
. infoArg "default .hpc [rarely used]"
srcDirOpt = anArg "srcdir" "path to source directory of .hs files" "DIR"
(\ a f -> f { srcDirs = srcDirs f ++ [a] })
. infoArg "multi-use of srcdir possible"
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 }
-- markup
perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
decListOpt = noArg "dec-list" "show unused decls" $ \ f -> f { decList = 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 }
......@@ -100,13 +110,19 @@ postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unt
$ \ f -> f { funTotals = True }
-------------------------------------------------------------------------------
readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags
| dir <- srcDirs flags
] mod
-------------------------------------------------------------------------------
command_usage plugin =
putStrLn $
"Usage: hpc " ++ (name plugin) ++ " " ++
(usage plugin) ++
if null (options plugin)
if null (options plugin [])
then ""
else usageInfo "\n\nOptions:\n" (options plugin)
else usageInfo "\n\nOptions:\n" (options plugin [])
hpcError :: Plugin -> String -> IO a
hpcError plugin msg = do
......@@ -118,7 +134,7 @@ hpcError plugin msg = do
data Plugin = Plugin { name :: String
, usage :: String
, options :: [OptDescr (Flags -> Flags)]
, options :: FlagOptSeq
, summary :: String
, implementation :: Flags -> [String] -> IO ()
, init_flags :: Flags
......@@ -135,15 +151,16 @@ 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
......
module HpcLexer where
import Data.Char
data Token
= ID String
| SYM Char
| INT Int
| STR String
deriving (Eq,Show)
initLexer :: String -> [Token]
initLexer str = [ t | (_,_,t) <- lexer str 1 0 ]
lexer :: String -> Int -> Int -> [(Int,Int,Token)]
lexer (c:cs) line column
| c == '\n' = lexer cs (succ line) 0
| c == '\"' = lexerSTR cs line (succ column)
| c `elem` "{};-:"
= (line,column,SYM c) : lexer cs line (succ column)
| isSpace c = lexer cs line (succ column)
| isAlpha c = lexerKW cs [c] line (succ column)
| isDigit c = lexerINT cs [c] line (succ column)
| otherwise = error "lexer failure"
lexer [] line colunm = []
lexerKW (c:cs) s line column
| isAlpha c = lexerKW cs (s ++ [c]) line (succ column)
lexerKW other s line column = (line,column,ID s) : lexer other line column
lexerINT (c:cs) s line column
| isDigit c = lexerINT cs (s ++ [c]) line (succ column)
lexerINT other s line column = (line,column,INT (read s)) : lexer other line column
-- not technically correct for the new column count, but a good approximation.
lexerSTR cs line column
= case lex ('"' : cs) of
[(str,rest)] -> (line,succ column,STR str)
: lexer rest line (length (show str) + column + 1)
_ -> error "bad string"
test = do
t <- readFile "EXAMPLE.tc"
print (initLexer t)
......@@ -11,6 +11,7 @@ import Trace.Hpc.Util
import HpcFlags
import System.Environment
import System.Directory
import Data.List
import Data.Maybe(fromJust)
......@@ -19,13 +20,14 @@ import qualified HpcSet as Set
------------------------------------------------------------------------------
markup_options =
[ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
, altHighlightOpt
#if __GLASGOW_HASKELL__ >= 604
, destDirOpt
#endif
]
markup_options
= excludeOpt
. includeOpt
. srcDirOpt
. hpcDirOpt
. funTotalsOpt
. altHighlightOpt
. destDirOpt
markup_plugin = Plugin { name = "markup"
, usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
......@@ -45,16 +47,14 @@ markup_main flags (prog:modNames) = do
`Set.union`
includeMods flags }
let Flags
{ hpcDirs = hpcDirs
, hsDirs = theHsPath
, funTotals = theFunTotals
{ funTotals = theFunTotals
, altHighlight = invertOutput
, destDir = dest_dir
} = hpcflags1
mtix <- readTix (getTixFileName prog)
Tix tixs <- case mtix of
Nothing -> error $ "unable to find tix file for: " ++ prog
Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog
Just a -> return a
#if __GLASGOW_HASKELL__ >= 604
......@@ -63,7 +63,7 @@ markup_main flags (prog:modNames) = do
#endif
mods <-
sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput
sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
| tix <- tixs
, allowModule hpcflags1 (tixModuleName tix)
]
......@@ -130,20 +130,20 @@ markup_main flags (prog:modNames) = do
(percent (expTicked s1) (expTotal s1))
markup_main flags [] = error $ "no .tix file or executable name specified"
markup_main flags [] = hpcError markup_plugin $ "no .tix file or executable name specified"
genHtmlFromMod
:: String
-> [FilePath]
-> Flags
-> TixModule
-> Bool
-> [String]
-> Bool
-> IO (String, [Char], ModuleSummary)
genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
let theHsPath = srcDirs flags
let modName0 = tixModuleName tix
(Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0
(Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags modName0
let arr_tix :: Array Int Integer
arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
......@@ -457,7 +457,8 @@ readFileFromPath filename@('/':_) _ = readFile filename
readFileFromPath filename path0 = readTheFile path0
where
readTheFile :: [String] -> IO String
readTheFile [] = error $ "could not find " ++ show filename
readTheFile [] = hpcError markup_plugin
$ "could not find " ++ show filename
++ " in path " ++ show path0
readTheFile (dir:dirs) =
catch (do str <- readFile (dir ++ "/" ++ filename)
......
module HpcOverlay where
import HpcFlags
import HpcParser
overlay_options
= srcDirOpt
. hpcDirOpt
. outputOpt
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 [] = hpcError overlay_plugin $ "no overlay file specified"
overlay_main flags files = do
print ("HERE", files)
result <- hpcParser (head files)
print result
return ()
{
module HpcParser where
import HpcLexer
}
%name parser
%tokentype { Token }
%error { \ e -> error $ show (take 10 e) }
%token
MODULE { ID "module" }
TICK { ID "tick" }
EXPRESSION { ID "expression" }
ON { ID "on" }
LINE { ID "line" }
POSITION { ID "position" }
FUNCTION { ID "function" }
INSIDE { ID "inside" }
AT { ID "at" }
':' { SYM ':' }
'-' { SYM '-' }
';' { SYM ';' }
'{' { SYM '{' }
'}' { SYM '}' }
int { INT $$ }
string { STR $$ }
cat { STR $$ }
%%
Spec :: { Spec }
Spec : Ticks Modules { Spec ($1 []) ($2 []) }
Modules :: { L (ModuleName,[Tick]) }
Modules : Modules Module { $1 . ((:) $2) }
| { id }
Module :: { (ModuleName,[Tick]) }
Module : MODULE string '{' TopTicks '}'
{ ($2,$4 []) }
TopTicks :: { L Tick }
TopTicks : TopTicks TopTick { $1 . ((:) $2) }
| { id }
TopTick :: { Tick }
TopTick : Tick { ExprTick $1 }
| TICK FUNCTION string optQual optCat ';'
{ TickFunction $3 $4 $5 }
| INSIDE string '{' TopTicks '}'
{ InsideFunction $2 ($4 []) }
Ticks :: { L ExprTick }
Ticks : Ticks Tick { $1 . ((:) $2) }
| { id }
Tick :: { ExprTick }
Tick : TICK optString optQual optCat ';'
{ TickExpression False $2 $3 $4 }
optString :: { Maybe String }
optString : string { Just $1 }
| { Nothing }
optQual :: { Maybe Qualifier }
optQual : ON LINE int { Just (OnLine $3) }
| AT POSITION int ':' int '-' int ':' int
{ Just (AtPosition $3 $5 $7 $9) }
| { Nothing }
optCat :: { Maybe String }
optCat : cat { Just $1 }
| { Nothing }
{
type L a = [a] -> [a]
type ModuleName = String
data Spec
= Spec [ExprTick] [(ModuleName,[Tick])]
deriving (Show)
data ExprTick
= TickExpression Bool (Maybe String) (Maybe Qualifier) (Maybe String)
deriving (Show)
data Tick
= ExprTick ExprTick
| TickFunction String (Maybe Qualifier) (Maybe String)
| InsideFunction String [Tick]
deriving (Show)
data Qualifier = OnLine Int
| AtPosition Int Int Int Int
deriving (Show)
hpcParser :: String -> IO Spec
hpcParser filename = do
txt <- readFile filename
let tokens = initLexer txt
return $ parser tokens
}
......@@ -5,7 +5,9 @@
module HpcReport (report_plugin) where
import System.Exit
import Prelude hiding (exp)
import System(getArgs)
import List(sort,intersperse)
import HpcFlags
import Trace.Hpc.Mix
......@@ -150,7 +152,7 @@ single (BinBox {}) = False
modInfo :: Flags -> Bool -> (String,[Integer]) -> IO ModInfo
modInfo hpcflags qualDecList (moduleName,tickCounts) = do
Mix _ _ _ _ mes <- readMix (hpcDirs hpcflags) moduleName
Mix _ _ _ _ mes <- readMixWithFlags hpcflags moduleName
return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
where
q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
......@@ -223,9 +225,9 @@ report_main hpcflags (progName:mods) = do
| TixModule m _h _ tcs <- tickCounts
, allowModule hpcflags1 m
]
Nothing -> error $ "unable to find tix file for:" ++ progName
Nothing -> hpcError report_plugin $ "unable to find tix file for:" ++ progName
report_main hpcflags [] =
hpcError report_plugin $ "no .tix file or executable name specified"
makeReport :: Flags -> String -> [(String,[Integer])] -> IO ()
makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
......@@ -259,5 +261,13 @@ xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),(
------------------------------------------------------------------------------
report_options = [perModuleOpt,decListOpt,excludeOpt,includeOpt,hpcDirOpt,xmlOutputOpt]
report_options
= perModuleOpt
. decListOpt
. excludeOpt
. includeOpt
. srcDirOpt
. hpcDirOpt
. xmlOutputOpt