ref: bd52802651088f538873b149768b5f2c13266296
parent: 066d714b427ac5dac48e636db1286e8b5c0c6781
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Feb 9 09:30:03 EST 2024
Make parse use a stateful token machine for the next token.
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -11,7 +11,7 @@
import MicroHs.Ident
--import Debug.Trace
-type P a = Prsr FilePath Token a
+type P a = Prsr FilePath [] Token a
getFileName :: P FilePath
getFileName = get
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -19,11 +19,13 @@
lookAhead,
inject, nextToken,
LastFail(..),
+ TokenMachine(..),
) where
--Ximport Prelude()
import Prelude
import Control.Applicative
import Control.Monad
+import Compat
data LastFail t
= LastFail Int [t] [String]
@@ -47,26 +49,45 @@
longests :: forall t . [LastFail t] -> LastFail t
longests xs = foldl1 longest xs
-data Res s t a = Many [(a, ([t], s))] (LastFail t)
+class TokenMachine tm where
+ tmNextToken :: forall t . tm t -> Maybe (t, tm t)
+ tmLeft :: forall t . tm t -> Int
+ tmInject :: forall t . [t] -> tm t -> tm t
+
+instance TokenMachine [] where
+ tmNextToken [] = Nothing
+ tmNextToken (t:ts) = Just (t, ts)
+ tmLeft ts = length ts
+ tmInject = (++)
+
+firstToken :: forall tm t . TokenMachine tm => tm t -> [t]
+firstToken tm =
+ case tmNextToken tm of
+ Nothing -> []
+ Just (t, _) -> [t]
+
+type Res :: Type -> (Type -> Type) -> Type -> Type -> Type
+data Res s tm t a = Many [(a, (tm t, s))] (LastFail t)
--deriving (Show)
-data Prsr s t a = P (([t], s) -> Res s t a)
+type Prsr :: Type -> (Type -> Type) -> Type -> Type -> Type
+data Prsr s tm t a = P ((tm t, s) -> Res s tm t a)
--instance Show (Prsr s t a) where show _ = "<<Prsr>>"
-runP :: forall s t a . Prsr s t a -> (([t], s) -> Res s t a)
+runP :: forall s tm t a . Prsr s tm t a -> ((tm t, s) -> Res s tm t a)
runP (P p) = p
-instance forall s t . Functor (Prsr s t) where
+instance forall s tm t . Functor (Prsr s tm t) where
fmap f p = P $ \ t ->
case runP p t of
Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf
-instance forall s t . Applicative (Prsr s t) where
+instance forall s tm t . Applicative (Prsr s tm t) where
pure a = P $ \ t -> Many [(a, t)] noFail
(<*>) = ap
(*>) p k = p >>= \ _ -> k
-instance forall s t . Monad (Prsr s t) where
+instance forall s tm t . Monad (Prsr s tm t) where
(>>=) p k = P $ \ t ->
case runP p t of
Many aus plf ->
@@ -75,11 +96,11 @@
(rss, lfs) -> Many (concat rss) (longests (plf : lfs))
return = pure
-instance forall s t . MonadFail (Prsr s t) where
- fail m = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [m])
+instance forall s t tm . TokenMachine tm => MonadFail (Prsr s tm t) where
+ fail m = P $ \ (ts, _) -> Many [] (LastFail (tmLeft ts) (firstToken ts) [m])
-instance forall s t . Alternative (Prsr s t) where
- empty = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [])
+instance forall s t tm . TokenMachine tm => Alternative (Prsr s tm t) where
+ empty = P $ \ (ts, _) -> Many [] (LastFail (tmLeft ts) (firstToken ts) [])
(<|>) p q = P $ \ t ->
case runP p t of
@@ -87,18 +108,18 @@
case runP q t of
Many b lfb -> Many (a ++ b) (longest lfa lfb)
-get :: forall s t . Prsr s t s
+get :: forall s tm t . Prsr s tm t s
get = P $ \ t@(_, s) -> Many [(s, t)] noFail
-put :: forall s t . s -> Prsr s t ()
+put :: forall s tm t . s -> Prsr s tm t ()
put s = P $ \ (ts, _) -> Many [((), (ts, s))] noFail
-modify :: forall s t . (s -> s) -> Prsr s t ()
+modify :: forall s tm t . (s -> s) -> Prsr s tm t ()
modify f = get >>= \ s -> put (f s)
-- Left biased choice
infixl 3 <|<
-(<|<) :: forall s t a . Prsr s t a -> Prsr s t a -> Prsr s t a
+(<|<) :: forall s tm t a . Prsr s tm t a -> Prsr s tm t a -> Prsr s tm t a
(<|<) p q = P $ \ t ->
case runP p t of
Many [] lfa ->
@@ -106,65 +127,50 @@
Many b lfb -> Many b (longest lfa lfb)
r -> r
-{--many :: forall s t a . Prsr s t a -> Prsr s t [a]
-many p = some p <|> pure []
-
-some :: forall s t a . Prsr s t a -> Prsr s t [a]
-some p = (:) <$> p <*> many p
--}
-
-{--optional :: forall s t a . Prsr s t a -> Prsr s t (Maybe a)
-optional p = (Just <$> p) <|> pure Nothing
--}
-
-emany :: forall s t a . Prsr s t a -> Prsr s t [a]
+emany :: forall s tm t a . Prsr s tm t a -> Prsr s tm t [a]
emany p = esome p <|< pure []
-esome :: forall s t a . Prsr s t a -> Prsr s t [a]
+esome :: forall s tm t a . Prsr s tm t a -> Prsr s tm t [a]
esome p = (:) <$> p <*> emany p
-eoptional :: forall s t a . Prsr s t a -> Prsr s t (Maybe a)
+eoptional :: forall s tm t a . Prsr s tm t a -> Prsr s tm t (Maybe a)
eoptional p = (Just <$> p) <|< pure Nothing
-runPrsr :: forall s t a . --X(Show a, Show s) =>
- s -> Prsr s t a -> [t] -> Either (LastFail t) [(a, s)]
+runPrsr :: forall s tm t a . --X(Show a, Show s) =>
+ s -> Prsr s tm t a -> tm t -> Either (LastFail t) [(a, s)]
runPrsr s (P p) f =
case p (f, s) of
Many [] lf -> Left lf
Many xs _ -> Right [(a, snd x) | (a, x) <- xs ]
-choice :: forall s t a . [Prsr s t a] -> Prsr s t a
+choice :: forall s tm t a . TokenMachine tm => [Prsr s tm t a] -> Prsr s tm t a
choice [] = empty
choice ps = foldr1 (<|>) ps
-satisfy :: forall s t . String -> (t -> Bool) -> Prsr s t t
+satisfy :: forall s tm t . TokenMachine tm => String -> (t -> Bool) -> Prsr s tm t t
satisfy msg f = P $ \ (acs, s) ->
- case acs of
- c:cs | f c -> Many [(c, (cs, s))] noFail
- _ -> Many [] (LastFail (length acs) (take 1 acs) [msg])
+ case tmNextToken acs of
+ Just (c, cs) | f c -> Many [(c, (cs, s))] noFail
+ _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg])
-satisfyM :: forall s t a . String -> (t -> Maybe a) -> Prsr s t a
+satisfyM :: forall s tm t a . TokenMachine tm => String -> (t -> Maybe a) -> Prsr s tm t a
satisfyM msg f = P $ \ (acs, s) ->
- case acs of
- c:cs | Just a <- f c -> Many [(a, (cs, s))] noFail
- _ -> Many [] (LastFail (length acs) (take 1 acs) [msg])
+ case tmNextToken acs of
+ Just (c, cs) | Just a <- f c -> Many [(a, (cs, s))] noFail
+ _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg])
-eof :: forall s t . Prsr s t ()
+eof :: forall s tm t . TokenMachine tm => Prsr s tm t ()
eof = P $ \ t@(cs, _) ->
- if null cs then
- Many [((), t)] noFail
- else
- Many [] (LastFail (length cs) (take 1 cs) ["eof"])
+ case tmNextToken cs of
+ Nothing -> Many [((), t)] noFail
+ Just _ -> Many [] (LastFail (tmLeft cs) (firstToken cs) ["eof"])
infixl 9 <?>
-(<?>) :: forall s t a . Prsr s t a -> String -> Prsr s t a
+(<?>) :: forall s tm t a . Prsr s tm t a -> String -> Prsr s tm t a
(<?>) p e = P $ \ t ->
-- trace ("<?> " ++ show e) $case runP p t of
- Many rs (LastFail l ts _) ->
- Many rs (LastFail l ts [e])
+ Many rs (LastFail l ts _) -> Many rs (LastFail l ts [e])
{-notFollowedBy :: forall s t a . Prsr s t a -> Prsr s t ()
@@ -174,32 +180,33 @@
_ -> Many [] (LastFail (length ts) (take 1 ts) ["!"])
-}
-lookAhead :: forall s t a . Prsr s t a -> Prsr s t ()
+lookAhead :: forall s tm t a . TokenMachine tm => Prsr s tm t a -> Prsr s tm t ()
lookAhead p = P $ \ t ->
case runP p t of
Many [] (LastFail l ts xs) -> Many [] (LastFail l (take 1 ts) xs)
_ -> Many [((), t)] noFail
-nextToken :: forall s t . Prsr s t t
+nextToken :: forall s tm t . TokenMachine tm => Prsr s tm t t
nextToken = P $ \ t@(cs, _) ->
- case cs of
- [] -> Many [] (LastFail (length cs) [] ["!eof"])
- c:_ -> Many [(c, t)] noFail
+ case tmNextToken cs of
+ Nothing -> Many [] (LastFail 0 [] ["!eof"])
+ Just (c, _) -> Many [(c, t)] noFail
-inject :: forall s t . [t] -> Prsr s t ()
-inject s = P $ \ (cs, st) -> Many [((), (s ++ cs, st))] noFail
+inject :: forall s tm t . TokenMachine tm => [t] -> Prsr s tm t ()
+inject s = P $ \ (cs, st) -> Many [((), (tmInject s cs, st))] noFail
-sepBy1 :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
+sepBy1 :: forall s tm t a sep . TokenMachine tm => Prsr s tm t a -> Prsr s tm t sep -> Prsr s tm t [a]
sepBy1 p sep = (:) <$> p <*> many (sep *> p)
-esepBy1 :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
+esepBy1 :: forall s tm t a sep . Prsr s tm t a -> Prsr s tm t sep -> Prsr s tm t [a]
esepBy1 p sep = (:) <$> p <*> emany (sep *> p)
-esepBy :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
+esepBy :: forall s tm t a sep . Prsr s tm t a -> Prsr s tm t sep -> Prsr s tm t [a]
esepBy p sep = esepBy1 p sep <|< pure []
-esepEndBy :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
+esepEndBy :: forall s tm t a sep . Prsr s tm t a -> Prsr s tm t sep -> Prsr s tm t [a]
esepEndBy p sep = esepEndBy1 p sep <|< pure []
-esepEndBy1 :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
+esepEndBy1 :: forall s tm t a sep . Prsr s tm t a -> Prsr s tm t sep -> Prsr s tm t [a]
esepEndBy1 p sep = (:) <$> p <*> ((sep *> esepEndBy p sep) <|< pure [])
+
--
⑨