-- (c) 2007 Andy Gill
-- Main driver for Hpc
+import Trace.Hpc.Tix
import HpcFlags
import System.Environment
import System.Exit
import HpcCombine
import HpcShowTix
import HpcDraft
+import HpcOverlay
helpList :: IO ()
helpList =
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)
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
, markup_plugin
, combine_plugin
, showtix_plugin
+ , overlay_plugin
, draft_plugin
, version_plugin
]
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
version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev"
-------------------------------------------------------------------------------
+------------------------------------------------------------------------------
\ No newline at end of file
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> ..]]"
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>"
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))
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)
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) ++ ";"
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 ++ "}"
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
{ outputFile = "-"
, includeMods = Set.empty
, excludeMods = Set.empty
- , hpcDirs = []
- , hsDirs = []
+ , hpcDir = ".hpc"
+ , srcDirs = []
, destDir = "."
, perModule = False
-- 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 }
$ \ 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
data Plugin = Plugin { name :: String
, usage :: String
- , options :: [OptDescr (Flags -> Flags)]
+ , options :: FlagOptSeq
, summary :: String
, implementation :: Flags -> [String] -> IO ()
, init_flags :: Flags
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
--- /dev/null
+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)
+
import HpcFlags
+import System.Environment
import System.Directory
import Data.List
import Data.Maybe(fromJust)
------------------------------------------------------------------------------
-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> ..]]"
`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
#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)
]
(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)
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)
--- /dev/null
+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 ()
+
+
--- /dev/null
+{
+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
+
+
+}
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
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)}
| 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
------------------------------------------------------------------------------
-report_options = [perModuleOpt,decListOpt,excludeOpt,includeOpt,hpcDirOpt,xmlOutputOpt]
+report_options
+ = perModuleOpt
+ . decListOpt
+ . excludeOpt
+ . includeOpt
+ . srcDirOpt
+ . hpcDirOpt
+ . xmlOutputOpt
+
import Trace.Hpc.Mix
import Trace.Hpc.Tix
+import Trace.Hpc.Util
import HpcFlags
import qualified HpcSet as Set
-showtix_options =
- [ excludeOpt,includeOpt,hpcDirOpt
- , outputOpt
- ]
+showtix_options
+ = excludeOpt
+ . includeOpt
+ . srcDirOpt
+ . hpcDirOpt
+ . outputOpt
showtix_plugin = Plugin { name = "show"
, usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
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
+ tixs_mixs <- sequence
+ [ do mix <- readMixWithFlags hpcflags1 (tixModuleName tix)
+ return $ (tix,mix)
+ | tix <- tixs
+ , allowModule hpcflags1 (tixModuleName tix)
]
let rjust n str = take (n - length str) (repeat ' ') ++ str
]
| ( TixModule modName hash _ tixs
, Mix _file _timestamp _hash _tab entries
- ) <- zip tixs mixs
+ ) <- tixs_mixs
]
return ()
+
projects / ghc-hetmet.git / commitdiff