1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
{-# 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 Debug.Trace
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))
traceM (show cols)
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 + 6
, cIvT = centr + 7
, cIvA = civt + 5
, cIhT = civa + 6
, cIhA = ciht + 5 }
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)
|
