Lib.hs

module Parser.Lib where

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.Text as T

import Common
import Parser.Parser

runParserEither :: forall s a m. (Show s, HaveLocation s, HasEmpty s, MonadIO m) => ParserM m s a -> s -> m (Either (ParseErrorWithParsed a) a)
runParserEither (ParserM _ fn) s = do
  (r, rst) <- fn s
  case r of
    Right res ->
      if isEmpty rst then pure $ Right res else pure $ Left $ ParseErrorWithParsed (Just res) (getLocation rst) (FatalError IncompleteParse)
    Left err -> pure $ Left $ ParseErrorWithParsed Nothing (getLocation rst) err

runParser :: forall a s m. (Show s, HaveLocation s, HasEmpty s, MonadIO m) => ParserM m s a -> s -> m (Maybe a)
runParser p s = runParserEither p s >>= \case
  Right a -> pure $ Just a
  Left _  -> pure Nothing

incLine :: Int -> Parser ()
incLine lc = ParserM "" $ \s ->  pure (Right (), s { twLocation = moveLines (twLocation s) lc })

lookAhead :: Monad m => ParserM m s a -> ParserM m s (Maybe a)
lookAhead (ParserM name fn) = ParserM ("lookahead for (" <> name <> ")") $ \s ->
  fn s >>= \case
    (Right a, _) -> pure (Right $ Just a, s)
    (_, _)     -> pure (Right Nothing, s)

eof :: (HasEof s, Monad m) => ParserM m s ()
eof = ParserM "EOF" $ \s -> case isEof s of
  True  -> pure (Right (), s)
  False -> pure (Left CantHandle, s)

noteof :: (HasEof s, Monad m) => ParserM m s ()
noteof = ParserM "NOT_EOF" $ \s -> case isEof s of
  True -> pure (Left CantHandle, s)
  False  -> pure (Right (), s)

pAny :: (Char -> Bool) -> Parser Char
pAny fn = ParserM "" (\t ->
    pure $ case T.uncons $ twText t of
      Just (h, rst) -> if (fn h)
        then (Right h, t { twText = rst, twLocation = moveCols (twLocation t) 1 })
        else (Left CantHandle, t)
      Nothing -> (Left CantHandle, t)
  )

pChar :: Char -> Parser Char
pChar c = pAny (== c)

pText :: Text -> Parser Text
pText l = ParserM l (\t ->
  pure $ if isPrefixOf l $ twText t
    then let tLen = T.length l
      in (Right l, t { twText = T.drop tLen $ twText t, twLocation = moveCols (twLocation t) tLen})
    else (Left CantHandle, t))

parseAndReturn :: Text -> a -> Parser a
parseAndReturn t a = do
  void $ pText t
  pure a

testParser :: Parser [Char]
testParser = do
  a <- pChar 'a'
  b <- pChar 'b'
  pure [a, b]

cantHandle :: Monad m => ParserM m s a
cantHandle = ParserM "" (\s -> pure (Left CantHandle, s))

nameParser :: Text -> ParserM m s a -> ParserM m s a
nameParser name (ParserM _ f) = ParserM name f

class HasInnerParseable a where
  type InnerToken a
  assemble :: InnerToken a -> Location -> Int -> a

class HasParser a where
  parser :: Parser a

instance HasParser a => HasParser [a] where
  parser = many parser

instance {-# OVERLAPPABLE #-} (HasInnerParseable a, ToSource (InnerToken a), HasParser (InnerToken a)) => HasParser a where
  parser = do
    lc <- getParserLocation
    tr <- parser @(InnerToken a)
    let tLength = (T.length $ toSource tr)
    incOffset tLength
    pure $ assemble tr lc (lcOffset lc + tLength - 1)
    where
      incOffset :: Int -> Parser ()
      incOffset size = ParserM "" $ \s -> let
        location = twLocation s
        currentOffset = lcOffset location
        in pure (Right (), s { twLocation =  location { lcOffset = currentOffset + size }} )