diff options
Diffstat (limited to 'Parse.hs')
| -rw-r--r-- | Parse.hs | 131 |
1 files changed, 131 insertions, 0 deletions
diff --git a/Parse.hs b/Parse.hs new file mode 100644 index 0000000..0ee5004 --- /dev/null +++ b/Parse.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +module Parse (parseProf) where + +import Control.Applicative ((<|>)) +import Control.Monad (guard) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Short as BSS +import Data.ByteString (ByteString) +import Data.Char +import Data.List (unfoldr) + +import Prof + + +data Columns + = Columns { cMod :: Int + , cSrc :: Int + , cNo :: Int + , cCnt :: Int + , cIvT :: Int -- individual time/alloc + , cIvA :: Int + , cIhT :: Int -- inherited time/alloc + , cIhA :: Int } + deriving (Show) + +parseProf :: ByteString -> Either String (Prof ()) +parseProf input = do + (cols, lns) <- maybe (Left "Did not find tree header") Right (findTree (BS.split 10 input)) + lns' <- concat <$> mapM (parseLine cols) lns + case buildTree lns' of + Just (tree, []) -> return (Prof tree) + Just (_, l) -> Left ("Found " ++ show (length l) ++ " unexpected lines after tree") + Nothing -> Left "Empty tree found" + +parseLine :: Columns -> ByteString -> Either String [(Int, Entry)] +parseLine _ line | BS.null line = Right [] +parseLine cols line = either (\err -> Left (err ++ ": <" ++ BS8.unpack line ++ ">")) Right $ do + let indent = BS.length (BS.takeWhile (== 32) line) + scs = getCol 0 (cMod cols) + smod = getCol (cMod cols) (cSrc cols) + ssrc = getCol (cSrc cols) (cNo cols) + scnt = getCol (cCnt cols) (cIvT cols) + sivt = getCol (cIvT cols) (cIvA cols) + siva = getCol (cIvA cols) (cIhT cols) + siht = getCol (cIhT cols) (cIhA cols) + siha = getCol (cIhA cols) (BS.length line) + smod' <- nonEmpty smod "module" + ssrc' <- nonEmpty ssrc "src" + ncnt <- parseInt scnt "entries" + fivt <- parseFloat sivt "individual %time" + fiva <- parseFloat siva "individual %alloc" + fiht <- parseFloat siht "inherited %time" + fiha <- parseFloat siha "inherited %alloc" + return [(indent, Entry { eCS = BSS.toShort scs + , eModule = BSS.toShort smod' + , eSrc = BSS.toShort ssrc' + , eCount = ncnt + , eIndividual = TimeShare fivt fiva + , eInherited = TimeShare fiht fiha })] + where + getCol :: Int -> Int -> ByteString + getCol from to = + let part = BS.drop from (BS.take to line) + in BS.dropWhile (== 32) (BS.dropWhileEnd (== 32) part) + + nonEmpty bs descr = if BS.null bs then Left ("Unexpected empty " ++ descr ++ " field") else Right bs + + parseInt bs descr = case BS8.readInt bs of + Just (n, rest) | BS.null rest -> Right n + _ -> Left ("Cannot parse integer from '" ++ BS8.unpack bs ++ "' in " ++ descr ++ " field: <" ++ BS8.unpack bs ++ ">") + + parseFloat bs descr = + let mres = do + (whole, bs1) <- BS8.readInt bs + guard (not (BS.null bs1) && BS.head bs1 == fromIntegral (ord '.')) + let sfract = BS.tail bs1 + (fract, bs2) <- BS8.readInt sfract + guard (BS.null bs2) + return (fromIntegral whole + fromIntegral fract / 10 ^ BS.length sfract) + in case mres of + Just f -> Right f + Nothing -> Left ("Cannot parse float from '" ++ BS8.unpack bs ++ "' in " ++ descr ++ " field: <" ++ BS8.unpack bs ++ ">") + +findTree :: [ByteString] -> Maybe (Columns, [ByteString]) +findTree [] = Nothing +findTree (ln:lns) = fmap (,lns) (parseLeadingTreeLine ln) <|> findTree lns + +parseLeadingTreeLine :: ByteString -> Maybe Columns +parseLeadingTreeLine bs = do + (0, bs1) <- findCol "COST CENTRE" 0 bs + (cmod, bs2) <- findCol "MODULE" 11 bs1 + (csrc, bs3) <- findCol "SRC" (cmod+6) bs2 + (cno, bs4) <- findCol "no." (csrc+3) bs3 + (centr, bs5) <- findCol "entries" (cno+3) bs4 + (civt, bs6) <- findCol "%time" (centr+7) bs5 + (civa, bs7) <- findCol "%alloc" (civt+5) bs6 + (ciht, bs8) <- findCol "%time" (civa+6) bs7 + (_ciha, _bs9) <- findCol "%alloc" (ciht+5) bs8 + return $ Columns { cMod = cmod + , cSrc = csrc + , cNo = cno + , cCnt = cno + 5 + , cIvT = centr + 6 + , cIvA = civt + 4 + , cIhT = civa + 5 + , cIhA = ciht + 4 } + where + findCol :: String -> Int -> ByteString -> Maybe (Int, ByteString) + findCol stag from = \line -> + case go 0 line of + Nothing -> Nothing + Just (col, rest) -> Just (from + col, rest) + where + tag :: ByteString + tag = BS.pack (map (fromIntegral . ord) stag) + + go :: Int -> ByteString -> Maybe (Int, ByteString) + go !idx line + | BS.length line < BS.length tag = Nothing + | BS.take (BS.length tag) line == tag = Just (idx, BS.drop (BS.length tag) line) + | otherwise = go (idx + 1) (BS.tail line) + +buildTree :: [(Int, Entry)] -> Maybe (ProfTree (), [(Int, Entry)]) +buildTree [] = Nothing +buildTree ((depth, entry) : items) = + let (below, after) = span ((> depth) . fst) items + subs = unfoldr buildTree below + in Just (Node entry () subs, after) |