Parsing.hs

module Caliper.Syntax.Parsing where

import Control.DeepSeq
import Control.Monad
import Data.Bifunctor qualified as Bi
import Data.Char
import Data.Function
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Text qualified as T
import Data.Time.Calendar
import Data.Time.LocalTime
import Data.Void
import Text.Megaparsec hiding (ParseError)
import Text.Megaparsec.Char

import Caliper.Syntax.Ast
import Caliper.Syntax.Position

type Parser = Parsec Void T.Text

drainLine :: Parser prefix -> Parser ()
drainLine p = do
  _ <- many (p & consumeCommentBlock)
  -- Think of sequence as products, failure is mzero and would make the entire chain 0.
  -- Here, if there are some spaces followed by something /not eol/, eol would fail.
  -- This would make entire part fail whilst hspace has consumed some space.
  -- We then backtrack the parser in such case.
  _ <- (p & consumeCommentLine) <|> try (hspace *> void eol)
  pure ()

consumeCommentBlock :: Parser prefix -> Parser ()
consumeCommentBlock p = hidden $ do
  _ <- try $ p *> "{-"
  _ <- manyTill (nested <|> void anySingle) (void "-}")
  pure ()
  where
    nested = pure () & consumeCommentBlock

consumeCommentLine :: Parser prefix -> Parser ()
consumeCommentLine p = hidden $ do
  _ <- try $ p *> "--"
  _ <- manyTill anySingle (void eol <|> eof)
  pure ()

caliperAst :: Parser RawAst
caliperAst =
  many (pure () & drainLine)
    *> ( RawAst
           <$> (T.pack . sourceName <$> getSourcePos)
           <*> typeDecls
           <*> entriesOrTZ
       )
    <* eof

typeDecls :: Parser [T.Text]
typeDecls = typeDecl `sepEndBy` many (hspace & drainLine)

typeDecl :: Parser T.Text
typeDecl = label "type declaration" $ do
  _ <- "type" *> hspace1
  t <- T.pack <$> some valueChar
  _ <- hspace & drainLine
  pure t

entriesOrTZ :: Parser [EntriesOrTZ]
entriesOrTZ =
  many $
    (RawEntries <$> entries)
      <|> (TZDecl <$> tzDecl)

entries :: Parser [RawEntry]
entries = entry `sepEndBy1` many (hspace & drainLine)

tzDecl :: Parser TimeZone
tzDecl = do
  _ <- "timezone" *> hspace1
  sign <- (-1) <$ char '-' <|> 1 <$ char '+' <|> pure 1
  hh <- (try (decimalOfLength 2) <|> decimalOfLength 1) <* sep
  mm <- decimalOfLength 2
  _ <- many (hspace & drainLine)
  pure $ TimeZone (sign * (hh * 60 + mm)) False ""
  where
    sep :: Parser Char
    sep = satisfy (not . isDigit) <?> "non-digit separator"

entry :: Parser RawEntry
entry = label "entry" $ do
  entryStart <- localTime
  _ <- sep *> "..." <* sep
  entryEnd <- localTime
  _ <- hspace & drainLine -- End of line comment
  tags <-
    many (hspace & drainLine) -- Leading inner comment
      *> metadata

  -- This part creates thunk build-up, force the thunk here
  let re =
        RawEntry
          { rawEntryStart = fst entryStart
          , rawEntryEnd = entryEnd
          , rawEntryMetadata = tags
          }
  re `deepseq` pure re
  where
    sep :: Parser ()
    sep = void $ many go
      where
        go = hspace1 <|> (pure () & consumeCommentBlock)

-- | A time in the format of yyyy-mm-dd-hh-mm-ss, where dashes are a single non digit separator.
localTime :: Parser (LocalTime, SrcSpan)
localTime = do
  mkSrcSpan <- srcSpan
  startPos <- srcPosition
  t <- LocalTime <$> (parseDay <* sep) <*> parseTime
  endPos <- srcPosition
  pure (t, mkSrcSpan startPos endPos)
  where
    sep :: Parser Char
    sep = satisfy (not . isDigit) <?> "non-digit separator"

    parseDay :: Parser Day
    parseDay = do
      backtrack <- getOffset
      yyyy <- decimalOfLength 4 <* sep
      mm <- decimalOfLength 2 <* sep
      dd <- decimalOfLength 2
      case fromGregorianValid yyyy mm dd of
        Nothing -> do
          setOffset backtrack
          unexpected (Label $ 'i' NE.:| "nvalid calendar date")
        Just x -> pure x

    parseTime :: Parser TimeOfDay
    parseTime = do
      backtrack <- getOffset
      hh <- decimalOfLength 2 <* sep
      mm <- decimalOfLength 2 <* sep
      ss <- (decimalOfLength 2) <|> (0 <$ "__") -- unknown second notation
      case makeTimeOfDayValid hh mm ss of
        Nothing -> do
          setOffset backtrack
          unexpected (Label $ 'i' NE.:| "nvalid time")
        Just x -> pure x

decimalOfLength :: Num a => Int -> Parser a
decimalOfLength = fmap (fromIntegral . foldl' go 0) . flip replicateM (satisfy isDigit)
  where
    go :: Int -> Char -> Int
    go acc x = acc * 10 + fromEnum x - fromEnum '0'

metadata :: Parser (M.Map T.Text (NE.NonEmpty (T.Text, SrcSpan)))
metadata =
  finalize
    . M.fromListWith (<>)
    . nonEmptyValue
    <$> (hspace1 & keyValuePair) `sepEndBy` many (hspace & drainLine)
  where
    finalize = fmap NE.reverse

    nonEmptyValue :: [(a, b)] -> [(a, NE.NonEmpty b)]
    nonEmptyValue = map (Bi.second pure)

keyValuePair :: Parser prefix -> Parser (T.Text, (T.Text, SrcSpan))
keyValuePair p = do
  mkSrcSpan <- srcSpan
  (startPos, k) <- try $ do
    _ <- p
    liftA2 (,) srcPosition (T.pack <$> some keyChar)
  _ <- single ':'
  v <- T.pack <$> some valueChar
  endPos <- srcPosition
  let spn = mkSrcSpan startPos endPos
  pure (k, (v, spn))

keyChar :: Parser Char
keyChar = letterChar

valueChar :: Parser Char
valueChar = alphaNumChar <|> char '\'' -- we haskellers gotta allow ' in names

srcSpan :: Parser (SrcPosition -> SrcPosition -> SrcSpan)
srcSpan = do
  SourcePos {sourceName = fname} <- getSourcePos
  pure (SrcSpan (T.pack fname))

srcPosition :: Parser SrcPosition
srcPosition = do
  SourcePos
    { sourceLine = l
    , sourceColumn = c
    } <-
    getSourcePos
  pure (SrcPosition (unPos l) (unPos c))