{-# 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)