help_plugin = Plugin { name = "help"
, usage = "[<HPC_COMMAND>]"
- , summary = "Display help for hpc or a single command."
+ , summary = "Display help for hpc or a single command"
, options = help_options
, implementation = help_main
, init_flags = default_flags
, final_flags = default_final_flags
}
-version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev"
+version_main _ _ = putStrLn $ "hpc tools, version 0.6"
-------------------------------------------------------------------------------
\ No newline at end of file
+------------------------------------------------------------------------------
hash = tixModuleHash tix
tixs = tixModuleTixs tix
- mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags tix
+ mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags (Right tix)
let forest = createMixEntryDom
[ (span,(box,v > 0))
let non_ticked = findNotTickedFromList forest
- hs <- readFileFromPath filepath (srcDirs hpcflags)
+ hs <- readFileFromPath (hpcError draft_plugin) filepath (srcDirs hpcflags)
let hsMap :: Map.Map Int String
hsMap = Map.fromList (zip [1..] $ lines hs)
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)
$ \ f -> f { funTotals = True }
-------------------------------------------------------------------------------
-readMixWithFlags :: Flags -> TixModule -> IO Mix
+readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags
| dir <- srcDirs flags
] mod
| SYM Char
| INT Int
| STR String
+ | CAT String
deriving (Eq,Show)
initLexer :: String -> [Token]
lexer (c:cs) line column
| c == '\n' = lexer cs (succ line) 0
| 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)
-- 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)
+ [(str,rest)] -> (line,succ column,STR (read str))
: lexer rest line (length (show str) + column + 1)
_ -> error "bad string"
+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 other s line column = error "lexer failure in CAT"
+
test = do
t <- readFile "EXAMPLE.tc"
print (initLexer t)
lookup :: Ord key => key -> Map key elt -> Maybe elt
fromList :: Ord key => [(key,elt)] -> Map key elt
-
+fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
#if __GLASGOW_HASKELL__ < 604
type Map key elt = Map.FiniteMap key elt
lookup = Map.lookup
fromList = Map.fromList
+toList = Map.toList
+fromListWith = Map.fromListWith
#endif
import Trace.Hpc.Util
import HpcFlags
+import HpcUtils
import System.Environment
import System.Directory
let theHsPath = srcDirs flags
let modName0 = tixModuleName tix
- (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags tix
+ (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags (Right tix)
let arr_tix :: Array Int Integer
arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
}
-- add prefix to modName argument
- content <- readFileFromPath origFile theHsPath
+ content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath
let content' = markup tabStop info content
let show' = reverse . take 5 . (++ " ") . reverse . show
green = "#60de51"
yellow = "yellow"
-------------------------------------------------------------------------------
-
-readFileFromPath :: String -> [String] -> IO String
-readFileFromPath filename@('/':_) _ = readFile filename
-readFileFromPath filename path0 = readTheFile path0
- where
- readTheFile :: [String] -> IO String
- readTheFile [] = hpcError markup_plugin
- $ "could not find " ++ show filename
- ++ " in path " ++ show path0
- readTheFile (dir:dirs) =
- catch (do str <- readFile (dir ++ "/" ++ filename)
- return str)
- (\ _ -> readTheFile dirs)
import HpcFlags
import HpcParser
+import HpcUtils
+import Trace.Hpc.Tix
+import Trace.Hpc.Mix
+import Trace.Hpc.Util
+import HpcMap as Map
+import Data.Tree
overlay_options
= srcDirOpt
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 ()
-
-
+ specs <- mapM hpcParser files
+ let spec@(Spec globals modules) = concatSpec specs
+
+ let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]
+
+ mod_info <-
+ sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left mod)
+ content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
+ processModule mod content mix mod_spec globals
+ | (mod,mod_spec) <- Map.toList modules1
+ ]
+
+
+ let tix = Tix $ mod_info
+
+ case outputFile flags of
+ "-" -> putStrLn (show 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 modName modContents (Mix filepath timestamp hash tabstop 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 g) =
+ 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 g) =
+ 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' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
+
+ let forest = createMixEntryDom
+ [ (span,ix)
+ | ((span,_),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 pos Nothing = True
+qualifier pos (Just (OnLine n)) = n == l1 && n == l2
+ where (l1,c1,l2,c2) = fromHpcPos pos
+qualifier pos (Just (AtPosition l1' c1' l2' c2'))
+ = (l1', c1', l2', c2') == fromHpcPos pos
+
+concatSpec :: [Spec] -> Spec
+concatSpec = foldl1 $
+ \ (Spec pre1 body1) (Spec pre2 body2)
+ -> Spec (pre1 ++ pre2) (body1 ++ body2)
+
+
+
+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
+
+
'}' { SYM '}' }
int { INT $$ }
string { STR $$ }
- cat { STR $$ }
+ cat { CAT $$ }
%%
Spec :: { Spec }
modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do
- Mix _ _ _ _ mes <- readMixWithFlags hpcflags tix
+ Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix)
return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
where
q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
Nothing -> hpcError showtix_plugin $ "could not read .tix file : " ++ prog
Just (Tix tixs) -> do
tixs_mixs <- sequence
- [ do mix <- readMixWithFlags hpcflags1 tix
+ [ do mix <- readMixWithFlags hpcflags1 (Right tix)
return $ (tix,mix)
| tix <- tixs
, allowModule hpcflags1 (tixModuleName tix)
import Trace.Hpc.Util
import qualified HpcMap as Map
+import HpcFlags
-- turns \n into ' '
-- | grab's the text behind a HpcPos;
Nothing -> error $ "bad line number : " ++ show n
) [l1..l2]
+
+readFileFromPath :: (String -> IO String) -> String -> [String] -> IO String
+readFileFromPath err filename@('/':_) _ = readFile filename
+readFileFromPath err filename path0 = readTheFile path0
+ where
+ readTheFile [] = err $ "could not find " ++ show filename
+ ++ " in path " ++ show path0
+ readTheFile (dir:dirs) =
+ catch (do str <- readFile (dir ++ "/" ++ filename)
+ return str)
+ (\ _ -> readTheFile dirs)
projects / ghc-hetmet.git / commitdiff