From c23b7b5517d7ac5d0a6b2ff8a4f4914c2f392261 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Tue, 27 Oct 2020 13:12:58 +0100
Subject: Initial

---
 Parse.hs | 131 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 131 insertions(+)
 create mode 100644 Parse.hs

(limited to 'Parse.hs')

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)
-- 
cgit v1.2.3-54-g00ecf