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