{-# 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
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)
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
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))