{-# LANGUAGE UndecidableInstances #-}

module SimpleParser.LookAhead
  ( MatchCase (..)
  , PureMatchCase
  , DefaultCase (..)
  , PureDefaultCase
  , MatchBlock (..)
  , PureMatchBlock
  , lookAheadMatch
  , MatchPos (..)
  , LookAheadTestResult (..)
  , lookAheadTest
  , pureLookAheadTest
  , lookAheadChunk
  ) where

import Control.Monad (void)
import Control.Monad.Identity (Identity (runIdentity))
import Data.Sequence (Seq (..))
import Data.Sequence.NonEmpty (NESeq)
import qualified Data.Sequence.NonEmpty as NESeq
import SimpleParser.Input (matchChunk)
import SimpleParser.Parser (ParserT (..), markParser)
import SimpleParser.Result (ParseError, ParseResult (..))
import SimpleParser.Stream (Stream (..))

data MatchCase l s e m a = MatchCase
  { MatchCase l s e m a -> Maybe l
matchCaseLabel :: !(Maybe l)
  , MatchCase l s e m a -> ParserT l s e m ()
matchCaseGuard :: !(ParserT l s e m ())
  , MatchCase l s e m a -> ParserT l s e m a
matchCaseBody :: !(ParserT l s e m a)
  }

type PureMatchCase l s e a = MatchCase l s e Identity a

data MatchMiss l s e = MatchMiss
  { MatchMiss l s e -> Maybe l
matchMissLabel :: !(Maybe l)
  , MatchMiss l s e -> Maybe (NESeq (ParseError l s e))
matchMissErrors :: !(Maybe (NESeq (ParseError l s e)))
  }

deriving instance (Eq l, Eq s, Eq (Token s), Eq (Chunk s), Eq e) => Eq (MatchMiss l s e)
deriving instance (Show l, Show s, Show (Token s), Show (Chunk s), Show e) => Show (MatchMiss l s e)

data DefaultCase l s e m a = DefaultCase
  { DefaultCase l s e m a -> Maybe l
defaultCaseLabel :: !(Maybe l)
  , DefaultCase l s e m a -> Seq (MatchMiss l s e) -> ParserT l s e m a
defaultCaseHandle :: !(Seq (MatchMiss l s e) -> ParserT l s e m a)
  }

type PureDefaultCase l s e a = DefaultCase l s e Identity a

data MatchBlock l s e m a = MatchBlock
  { MatchBlock l s e m a -> DefaultCase l s e m a
matchBlockDefault :: !(DefaultCase l s e m a)
  , MatchBlock l s e m a -> [MatchCase l s e m a]
matchBlockElems :: ![MatchCase l s e m a]
  }

type PureMatchBlock l s e a = MatchBlock l s e Identity a

-- | Parse with look-ahead for each case and follow the first that matches (or follow the default if none do).
lookAheadMatch :: Monad m => MatchBlock l s e m a -> ParserT l s e m a
lookAheadMatch :: MatchBlock l s e m a -> ParserT l s e m a
lookAheadMatch (MatchBlock (DefaultCase Maybe l
dcl Seq (MatchMiss l s e) -> ParserT l s e m a
dch) [MatchCase l s e m a]
mcs) = (s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (Seq (MatchMiss l s e)
-> [MatchCase l s e m a] -> s -> m (Maybe (ParseResult l s e a))
go Seq (MatchMiss l s e)
forall a. Seq a
Empty [MatchCase l s e m a]
mcs) where
  go :: Seq (MatchMiss l s e)
-> [MatchCase l s e m a] -> s -> m (Maybe (ParseResult l s e a))
go !Seq (MatchMiss l s e)
macc [] s
s = ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT (Maybe l -> ParserT l s e m a -> ParserT l s e m a
forall (m :: * -> *) l s e a.
Monad m =>
Maybe l -> ParserT l s e m a -> ParserT l s e m a
markParser Maybe l
dcl (Seq (MatchMiss l s e) -> ParserT l s e m a
dch Seq (MatchMiss l s e)
macc)) s
s
  go !Seq (MatchMiss l s e)
macc ((MatchCase Maybe l
mcl ParserT l s e m ()
mcg ParserT l s e m a
mcb):[MatchCase l s e m a]
mcs') s
s = do
    Maybe (ParseResult l s e ())
mres <- ParserT l s e m () -> s -> m (Maybe (ParseResult l s e ()))
forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m ()
mcg s
s
    case Maybe (ParseResult l s e ())
mres of
      Maybe (ParseResult l s e ())
Nothing -> Seq (MatchMiss l s e)
-> [MatchCase l s e m a] -> s -> m (Maybe (ParseResult l s e a))
go (Seq (MatchMiss l s e)
macc Seq (MatchMiss l s e) -> MatchMiss l s e -> Seq (MatchMiss l s e)
forall a. Seq a -> a -> Seq a
:|> Maybe l -> Maybe (NESeq (ParseError l s e)) -> MatchMiss l s e
forall l s e.
Maybe l -> Maybe (NESeq (ParseError l s e)) -> MatchMiss l s e
MatchMiss Maybe l
mcl Maybe (NESeq (ParseError l s e))
forall a. Maybe a
Nothing) [MatchCase l s e m a]
mcs' s
s
      Just (ParseResultError NESeq (ParseError l s e)
es) -> Seq (MatchMiss l s e)
-> [MatchCase l s e m a] -> s -> m (Maybe (ParseResult l s e a))
go (Seq (MatchMiss l s e)
macc Seq (MatchMiss l s e) -> MatchMiss l s e -> Seq (MatchMiss l s e)
forall a. Seq a -> a -> Seq a
:|> Maybe l -> Maybe (NESeq (ParseError l s e)) -> MatchMiss l s e
forall l s e.
Maybe l -> Maybe (NESeq (ParseError l s e)) -> MatchMiss l s e
MatchMiss Maybe l
mcl (NESeq (ParseError l s e) -> Maybe (NESeq (ParseError l s e))
forall a. a -> Maybe a
Just NESeq (ParseError l s e)
es)) [MatchCase l s e m a]
mcs' s
s
      Just (ParseResultSuccess ParseSuccess s ()
_) -> ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT (Maybe l -> ParserT l s e m a -> ParserT l s e m a
forall (m :: * -> *) l s e a.
Monad m =>
Maybe l -> ParserT l s e m a -> ParserT l s e m a
markParser Maybe l
mcl ParserT l s e m a
mcb) s
s

data MatchPos l = MatchPos
  { MatchPos l -> Int
matchPosIndex :: !Int
  , MatchPos l -> Maybe l
matchPosLabel :: !(Maybe l)
  } deriving stock (MatchPos l -> MatchPos l -> Bool
(MatchPos l -> MatchPos l -> Bool)
-> (MatchPos l -> MatchPos l -> Bool) -> Eq (MatchPos l)
forall l. Eq l => MatchPos l -> MatchPos l -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MatchPos l -> MatchPos l -> Bool
$c/= :: forall l. Eq l => MatchPos l -> MatchPos l -> Bool
== :: MatchPos l -> MatchPos l -> Bool
$c== :: forall l. Eq l => MatchPos l -> MatchPos l -> Bool
Eq, Int -> MatchPos l -> ShowS
[MatchPos l] -> ShowS
MatchPos l -> String
(Int -> MatchPos l -> ShowS)
-> (MatchPos l -> String)
-> ([MatchPos l] -> ShowS)
-> Show (MatchPos l)
forall l. Show l => Int -> MatchPos l -> ShowS
forall l. Show l => [MatchPos l] -> ShowS
forall l. Show l => MatchPos l -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatchPos l] -> ShowS
$cshowList :: forall l. Show l => [MatchPos l] -> ShowS
show :: MatchPos l -> String
$cshow :: forall l. Show l => MatchPos l -> String
showsPrec :: Int -> MatchPos l -> ShowS
$cshowsPrec :: forall l. Show l => Int -> MatchPos l -> ShowS
Show)

data LookAheadTestResult l =
    LookAheadTestDefault !(Maybe l)
  | LookAheadTestMatches !(NESeq (MatchPos l))
  deriving stock (LookAheadTestResult l -> LookAheadTestResult l -> Bool
(LookAheadTestResult l -> LookAheadTestResult l -> Bool)
-> (LookAheadTestResult l -> LookAheadTestResult l -> Bool)
-> Eq (LookAheadTestResult l)
forall l.
Eq l =>
LookAheadTestResult l -> LookAheadTestResult l -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LookAheadTestResult l -> LookAheadTestResult l -> Bool
$c/= :: forall l.
Eq l =>
LookAheadTestResult l -> LookAheadTestResult l -> Bool
== :: LookAheadTestResult l -> LookAheadTestResult l -> Bool
$c== :: forall l.
Eq l =>
LookAheadTestResult l -> LookAheadTestResult l -> Bool
Eq, Int -> LookAheadTestResult l -> ShowS
[LookAheadTestResult l] -> ShowS
LookAheadTestResult l -> String
(Int -> LookAheadTestResult l -> ShowS)
-> (LookAheadTestResult l -> String)
-> ([LookAheadTestResult l] -> ShowS)
-> Show (LookAheadTestResult l)
forall l. Show l => Int -> LookAheadTestResult l -> ShowS
forall l. Show l => [LookAheadTestResult l] -> ShowS
forall l. Show l => LookAheadTestResult l -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LookAheadTestResult l] -> ShowS
$cshowList :: forall l. Show l => [LookAheadTestResult l] -> ShowS
show :: LookAheadTestResult l -> String
$cshow :: forall l. Show l => LookAheadTestResult l -> String
showsPrec :: Int -> LookAheadTestResult l -> ShowS
$cshowsPrec :: forall l. Show l => Int -> LookAheadTestResult l -> ShowS
Show)

-- | Test which branches match the look-ahead. Useful to assert that your parser makes exclusive choices.
lookAheadTest :: Monad m => MatchBlock l s e m a -> s -> m (LookAheadTestResult l)
lookAheadTest :: MatchBlock l s e m a -> s -> m (LookAheadTestResult l)
lookAheadTest (MatchBlock (DefaultCase Maybe l
dcl Seq (MatchMiss l s e) -> ParserT l s e m a
_) [MatchCase l s e m a]
mcs) = Seq (MatchPos l)
-> Int -> [MatchCase l s e m a] -> s -> m (LookAheadTestResult l)
go Seq (MatchPos l)
forall a. Seq a
Empty Int
0 [MatchCase l s e m a]
mcs where
  go :: Seq (MatchPos l)
-> Int -> [MatchCase l s e m a] -> s -> m (LookAheadTestResult l)
go !Seq (MatchPos l)
acc Int
_ [] s
_ =
    case Seq (MatchPos l) -> Maybe (NESeq (MatchPos l))
forall a. Seq a -> Maybe (NESeq a)
NESeq.nonEmptySeq Seq (MatchPos l)
acc of
      Maybe (NESeq (MatchPos l))
Nothing -> LookAheadTestResult l -> m (LookAheadTestResult l)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe l -> LookAheadTestResult l
forall l. Maybe l -> LookAheadTestResult l
LookAheadTestDefault Maybe l
dcl)
      Just NESeq (MatchPos l)
ms -> LookAheadTestResult l -> m (LookAheadTestResult l)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NESeq (MatchPos l) -> LookAheadTestResult l
forall l. NESeq (MatchPos l) -> LookAheadTestResult l
LookAheadTestMatches NESeq (MatchPos l)
ms)
  go !Seq (MatchPos l)
acc !Int
i ((MatchCase Maybe l
mcl ParserT l s e m ()
mcg ParserT l s e m a
_):[MatchCase l s e m a]
mcs') s
s = do
    Maybe (ParseResult l s e ())
mres <- ParserT l s e m () -> s -> m (Maybe (ParseResult l s e ()))
forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m ()
mcg s
s
    case Maybe (ParseResult l s e ())
mres of
      Just (ParseResultSuccess ParseSuccess s ()
_) -> Seq (MatchPos l)
-> Int -> [MatchCase l s e m a] -> s -> m (LookAheadTestResult l)
go (Seq (MatchPos l)
acc Seq (MatchPos l) -> MatchPos l -> Seq (MatchPos l)
forall a. Seq a -> a -> Seq a
:|> Int -> Maybe l -> MatchPos l
forall l. Int -> Maybe l -> MatchPos l
MatchPos Int
i Maybe l
mcl) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [MatchCase l s e m a]
mcs' s
s
      Maybe (ParseResult l s e ())
_ -> Seq (MatchPos l)
-> Int -> [MatchCase l s e m a] -> s -> m (LookAheadTestResult l)
go Seq (MatchPos l)
acc (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [MatchCase l s e m a]
mcs' s
s

pureLookAheadTest :: PureMatchBlock l s e a -> s -> LookAheadTestResult l
pureLookAheadTest :: PureMatchBlock l s e a -> s -> LookAheadTestResult l
pureLookAheadTest PureMatchBlock l s e a
mb = Identity (LookAheadTestResult l) -> LookAheadTestResult l
forall a. Identity a -> a
runIdentity (Identity (LookAheadTestResult l) -> LookAheadTestResult l)
-> (s -> Identity (LookAheadTestResult l))
-> s
-> LookAheadTestResult l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureMatchBlock l s e a -> s -> Identity (LookAheadTestResult l)
forall (m :: * -> *) l s e a.
Monad m =>
MatchBlock l s e m a -> s -> m (LookAheadTestResult l)
lookAheadTest PureMatchBlock l s e a
mb

-- | Simple look-ahead that matches by chunk.
lookAheadChunk :: (Stream s, Monad m, Eq (Chunk s)) => [(Chunk s, ParserT l s e m a)] -> ParserT l s e m a -> ParserT l s e m a
lookAheadChunk :: [(Chunk s, ParserT l s e m a)]
-> ParserT l s e m a -> ParserT l s e m a
lookAheadChunk [(Chunk s, ParserT l s e m a)]
ps ParserT l s e m a
d = MatchBlock l s e m a -> ParserT l s e m a
forall (m :: * -> *) l s e a.
Monad m =>
MatchBlock l s e m a -> ParserT l s e m a
lookAheadMatch (DefaultCase l s e m a
-> [MatchCase l s e m a] -> MatchBlock l s e m a
forall l s e (m :: * -> *) a.
DefaultCase l s e m a
-> [MatchCase l s e m a] -> MatchBlock l s e m a
MatchBlock (Maybe l
-> (Seq (MatchMiss l s e) -> ParserT l s e m a)
-> DefaultCase l s e m a
forall l s e (m :: * -> *) a.
Maybe l
-> (Seq (MatchMiss l s e) -> ParserT l s e m a)
-> DefaultCase l s e m a
DefaultCase Maybe l
forall a. Maybe a
Nothing (ParserT l s e m a -> Seq (MatchMiss l s e) -> ParserT l s e m a
forall a b. a -> b -> a
const ParserT l s e m a
d)) (((Chunk s, ParserT l s e m a) -> MatchCase l s e m a)
-> [(Chunk s, ParserT l s e m a)] -> [MatchCase l s e m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Chunk s
c, ParserT l s e m a
p) -> Maybe l
-> ParserT l s e m () -> ParserT l s e m a -> MatchCase l s e m a
forall l s e (m :: * -> *) a.
Maybe l
-> ParserT l s e m () -> ParserT l s e m a -> MatchCase l s e m a
MatchCase Maybe l
forall a. Maybe a
Nothing (ParserT l s e m (Chunk s) -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Chunk s -> ParserT l s e m (Chunk s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Chunk s)) =>
Chunk s -> ParserT l s e m (Chunk s)
matchChunk Chunk s
c)) ParserT l s e m a
p) [(Chunk s, ParserT l s e m a)]
ps))