module FP.Parser.GreedyParser where

import FP.Prelude
import FP.Pretty
import FP.Parser.Common
import FP.Parser.Effects

-- WORK IN PROGRESS
--
-- Intent: Just like `Parser` but with greedy (PEG) semantics
-- - Non-distributive
-- - Much more efficient

-------------------------
-- Greedy Parser Monad --
-------------------------

newtype GreedyParser t a = GreedyParser
  { runGreedyParser ∷ 
      ReaderT (ParserEnv t) 
      (StateT (ParserState t) 
       (FailureT
        (Writer (ParserOut t)))) a 
  }
  deriving 
  (Functor,Monad
  ,MonadFailure
  ,MonadReader (ParserEnv t)
  ,MonadState (ParserState t)
  ,MonadWriter (ParserOut t)
  )

---------------------------
-- Primitive Combinators --
---------------------------

gpFail ∷ GreedyParser t a
gpFail = do
  pi ← getL parserStateInputL
  ek ← askL parserEnvErrorStackL
  pc ← getL parserStateErrorContextL
  tell $ ParserOut bot $ SourceErrorMaybe $ errorSourceLocalContext pi ek pc
  abort

gpPluck ∷ GreedyParser t t
gpPluck = do
  SourceInput ts nextLoc ← getL parserStateInputL
  case unconsStream ts of
    Nothing → gpAppendError "more input" gpFail
    Just (x,ts') → do
      let nextNextLoc = case unconsStream ts' of
            Nothing → bumpCol nextLoc
            Just (x',_) → locRangeBegin $ sourceTokenRange x'
      putL parserStateInputL $ SourceInput ts' nextNextLoc
      fmt ← askL parserEnvRenderFormatL
      modifyL parserStateErrorContextL $ \ pc → pc ⧺ sourceLocalContextFromToken fmt x
      modifyL parserStateCaptureContextL $ \ pc → pc ⧺ sourceLocalContextFromToken fmt x
      return $ sourceTokenValue x

gpAppendError ∷ 𝕊 → GreedyParser t a → GreedyParser t a
gpAppendError msg xM = do
  (stack,msg') ← askL parserEnvErrorStackL
  local (update parserEnvErrorStackL (msg':stack,msg)) xM

gpNewContext ∷ Lens (ParserState t) (SourceContextPrefix t) → GreedyParser t a → GreedyParser t (a,SourceContextPrefix t)
gpNewContext 𝓁 xM = do
  pc ← getL 𝓁
  putL 𝓁 $ pushSourceLocalContext pc
  x ← xM
  pc' ← getL 𝓁
  putL 𝓁 $ pc ⧺ pc'
  return (x,pc')

gpCapture ∷ GreedyParser t a → GreedyParser t (a,SourceContextPrefix t)
gpCapture = gpNewContext parserStateCaptureContextL

gpRender ∷ Format → GreedyParser t s → GreedyParser t s
gpRender fmt = local $ alter parserEnvRenderFormatL $ (⧺) [fmt]

gpEnd ∷ GreedyParser t ()
gpEnd = do
  ts ← getL (sourceInputStreamL ⌾ parserStateInputL)
  when (shape justL $ unconsStream ts) $ gpAppendError "end of stream" gpFail

gpCatch ∷ GreedyParser t a → GreedyParser t a → GreedyParser t a
gpCatch = (<|>)