{-# LANGUAGE UndecidableInstances #-}

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

import Control.Monad.Identity (Identity (runIdentity))
import Data.Sequence (Seq (..))
import Data.Sequence.NonEmpty (NESeq)
import qualified Data.Sequence.NonEmpty as NESeq
import SimpleParser.Parser (ParserT (..), lookAheadParser, markParser)
import SimpleParser.Result (ParseResult (..), ParseSuccess (..))

data MatchCase l s e m a b = MatchCase
  { MatchCase l s e m a b -> Maybe l
matchCaseLabel :: !(Maybe l)
  , MatchCase l s e m a b -> a -> Bool
matchCaseChoose :: !(a -> Bool)
  , MatchCase l s e m a b -> ParserT l s e m b
matchCaseHandle :: !(ParserT l s e m b)
  }

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

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

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

-- | 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 b -> ParserT l s e m b
lookAheadMatch :: MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch (MatchBlock ParserT l s e m a
sel ParserT l s e m b
dc [MatchCase l s e m a b]
mcs) = ParserT l s e m a -> ParserT l s e m a
forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a
lookAheadParser ParserT l s e m a
sel ParserT l s e m a -> (a -> ParserT l s e m b) -> ParserT l s e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [MatchCase l s e m a b] -> a -> ParserT l s e m b
go [MatchCase l s e m a b]
mcs where
  go :: [MatchCase l s e m a b] -> a -> ParserT l s e m b
go [] a
_ = ParserT l s e m b
dc
  go ((MatchCase Maybe l
mcl a -> Bool
mcg ParserT l s e m b
mch):[MatchCase l s e m a b]
mcs') a
val =
    if a -> Bool
mcg a
val
      then Maybe l -> ParserT l s e m b -> ParserT l s e m b
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 b
mch
      else [MatchCase l s e m a b] -> a -> ParserT l s e m b
go [MatchCase l s e m a b]
mcs' a
val

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 =
    LookAheadTestEmpty
  | LookAheadTestDefault
  | 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 b -> s -> m (LookAheadTestResult l)
lookAheadTest :: MatchBlock l s e m a b -> s -> m (LookAheadTestResult l)
lookAheadTest (MatchBlock ParserT l s e m a
sel ParserT l s e m b
_ [MatchCase l s e m a b]
mcs) = s -> m (LookAheadTestResult l)
go1 where
  go1 :: s -> m (LookAheadTestResult l)
go1 s
s = do
    Maybe (ParseResult l s e a)
mres <- 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 ParserT l s e m a
sel s
s
    case Maybe (ParseResult l s e a)
mres of
      Just (ParseResultSuccess (ParseSuccess s
_ a
val)) -> LookAheadTestResult l -> m (LookAheadTestResult l)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq (MatchPos l)
-> Int -> [MatchCase l s e m a b] -> a -> LookAheadTestResult l
forall l s e (m :: * -> *) t b.
Seq (MatchPos l)
-> Int -> [MatchCase l s e m t b] -> t -> LookAheadTestResult l
go2 Seq (MatchPos l)
forall a. Seq a
Empty Int
0 [MatchCase l s e m a b]
mcs a
val)
      Maybe (ParseResult l s e a)
_ -> LookAheadTestResult l -> m (LookAheadTestResult l)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LookAheadTestResult l
forall l. LookAheadTestResult l
LookAheadTestEmpty
  go2 :: Seq (MatchPos l)
-> Int -> [MatchCase l s e m t b] -> t -> LookAheadTestResult l
go2 !Seq (MatchPos l)
acc Int
_ [] t
_ = LookAheadTestResult l
-> (NESeq (MatchPos l) -> LookAheadTestResult l)
-> Maybe (NESeq (MatchPos l))
-> LookAheadTestResult l
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LookAheadTestResult l
forall l. LookAheadTestResult l
LookAheadTestDefault NESeq (MatchPos l) -> LookAheadTestResult l
forall l. NESeq (MatchPos l) -> LookAheadTestResult l
LookAheadTestMatches (Seq (MatchPos l) -> Maybe (NESeq (MatchPos l))
forall a. Seq a -> Maybe (NESeq a)
NESeq.nonEmptySeq Seq (MatchPos l)
acc)
  go2 !Seq (MatchPos l)
acc !Int
i ((MatchCase Maybe l
mcl t -> Bool
mcg ParserT l s e m b
_):[MatchCase l s e m t b]
mcs') t
val =
    if t -> Bool
mcg t
val
      then Seq (MatchPos l)
-> Int -> [MatchCase l s e m t b] -> t -> LookAheadTestResult l
go2 (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 t b]
mcs' t
val
      else Seq (MatchPos l)
-> Int -> [MatchCase l s e m t b] -> t -> LookAheadTestResult l
go2 Seq (MatchPos l)
acc (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [MatchCase l s e m t b]
mcs' t
val

pureLookAheadTest :: PureMatchBlock l s e a b -> s -> LookAheadTestResult l
pureLookAheadTest :: PureMatchBlock l s e a b -> s -> LookAheadTestResult l
pureLookAheadTest PureMatchBlock l s e a b
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 b -> s -> Identity (LookAheadTestResult l)
forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> s -> m (LookAheadTestResult l)
lookAheadTest PureMatchBlock l s e a b
mb

-- | Simple look-ahead that selects a parser based on first equal prefix.
lookAheadSimple :: (Monad m, Eq a) => ParserT l s e m a -> ParserT l s e m b -> [(a, ParserT l s e m b)] -> ParserT l s e m b
lookAheadSimple :: ParserT l s e m a
-> ParserT l s e m b
-> [(a, ParserT l s e m b)]
-> ParserT l s e m b
lookAheadSimple ParserT l s e m a
sel ParserT l s e m b
dc [(a, ParserT l s e m b)]
pairs = MatchBlock l s e m a b -> ParserT l s e m b
forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch (ParserT l s e m a
-> ParserT l s e m b
-> [MatchCase l s e m a b]
-> MatchBlock l s e m a b
forall l s e (m :: * -> *) a b.
ParserT l s e m a
-> ParserT l s e m b
-> [MatchCase l s e m a b]
-> MatchBlock l s e m a b
MatchBlock ParserT l s e m a
sel ParserT l s e m b
dc [MatchCase l s e m a b]
mcs) where
  mcs :: [MatchCase l s e m a b]
mcs = [Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe l
forall a. Maybe a
Nothing (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) ParserT l s e m b
p | (a
x, ParserT l s e m b
p) <- [(a, ParserT l s e m b)]
pairs]