{-# LANGUAGE UndecidableInstances #-}
module SimpleParser.LookAhead
( MatchCase (..)
, PureMatchCase
, MatchBlock (..)
, PureMatchBlock
, lookAheadMatch
, consumeMatch
, 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
{ forall l s e (m :: * -> *) a b. MatchCase l s e m a b -> Maybe l
matchCaseLabel :: !(Maybe l)
, forall l s e (m :: * -> *) a b. MatchCase l s e m a b -> a -> Bool
matchCaseChoose :: !(a -> Bool)
, forall l s e (m :: * -> *) a b.
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
{ forall l s e (m :: * -> *) a b.
MatchBlock l s e m a b -> ParserT l s e m a
matchBlockSelect :: !(ParserT l s e m a)
, forall l s e (m :: * -> *) a b.
MatchBlock l s e m a b -> ParserT l s e m b
matchBlockDefault :: !(ParserT l s e m b)
, forall l s e (m :: * -> *) a 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
lookAheadMatch :: Monad m => MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch :: forall (m :: * -> *) l s e a b.
Monad m =>
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) = 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 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 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
consumeMatch :: Monad m => MatchBlock l s e m a b -> ParserT l s e m b
consumeMatch :: forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
consumeMatch (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
sel 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 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
{ forall l. MatchPos l -> Int
matchPosIndex :: !Int
, forall l. MatchPos l -> Maybe l
matchPosLabel :: !(Maybe l)
} deriving stock (MatchPos l -> MatchPos l -> Bool
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
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
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
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 b -> s -> m (LookAheadTestResult l)
lookAheadTest :: forall (m :: * -> *) l s e a b.
Monad m =>
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 <- 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)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {l} {s} {e} {m :: * -> *} {t} {b}.
Seq (MatchPos l)
-> Int -> [MatchCase l s e m t b] -> t -> LookAheadTestResult l
go2 forall a. Seq a
Empty Int
0 [MatchCase l s e m a b]
mcs a
val)
Maybe (ParseResult l s e a)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
_ = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall l. LookAheadTestResult l
LookAheadTestDefault forall l. NESeq (MatchPos l) -> LookAheadTestResult l
LookAheadTestMatches (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 forall a. Seq a -> a -> Seq a
:|> forall l. Int -> Maybe l -> MatchPos l
MatchPos Int
i Maybe l
mcl) (Int
i 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 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 :: forall l s e a b.
PureMatchBlock l s e a b -> s -> LookAheadTestResult l
pureLookAheadTest PureMatchBlock l s e a b
mb = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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 :: forall (m :: * -> *) a l s e b.
(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
sel ParserT l s e m b
dc [(a, ParserT l s e m b)]
pairs = forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch (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 = [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 forall a. Maybe a
Nothing (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]