Common.hs

module Compiler.AST.Parser.Common where

import Compiler.Lexer
import Parser
import Common

type AstParser a = ParserM IO AstParserState a

data AstParserState = AstParserState
  { astInput           :: [Token]
  , astIndent          :: Int
  , astGeneratorFlag   :: Bool
  } deriving Show

setGeneratorFlag :: Bool -> AstParser ()
setGeneratorFlag f = ParserM "" (\s -> pure $ (Right (), s { astGeneratorFlag = f }))

getGeneratorFlag :: AstParser Bool
getGeneratorFlag = ParserM "" (\s -> pure $ (Right $ astGeneratorFlag s, s))

instance HaveLocation AstParserState where
  getLocation (astInput -> (t:_)) =  tkLocation t
  getLocation _ = error "No location for empty input"

instance HasEmpty AstParserState where
  isEmpty s = astInput s == []

mkAstParserState :: [Token] -> AstParserState
mkAstParserState ts = AstParserState ts 0 False

liftModifier
  :: Monad m
  => ([Token] -> m (Either ParseError a, [Token]))
  -> (AstParserState -> m (Either ParseError a, AstParserState))
liftModifier fn = \s -> do
  (fn $ astInput s) >>= \case
    (r, rst) -> pure (r, s { astInput = rst })

instance {-# OVERLAPS #-} HasLogIndent AstParserState where
  incIndent a = a { astIndent = astIndent a + 1 }
  decIndent a = a { astIndent = astIndent a - 1 }
  logInfo _ _ = pure ()
  -- logInfo name ps = liftIO $ do
  --   T.putStr $ T.replicate (astIndent ps) " "
  --   T.putStrLn $ T.pack $ show (name, Prelude.take 2 $ astInput ps)

instance ToSource AstParserState where
  toSource s = toSource $ astInput s

class HasAstParser a where
  astParser :: AstParser a