From 5a659d22dd260b7b565073865fda4fbec2749c61 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 22 Jan 2024 09:55:58 -0700 Subject: [PATCH] errorful parser --- src/Control/Monad/Errorful.hs | 13 ++++++-- src/Rlp/Lex.x | 16 +++++----- src/Rlp/Parse.y | 2 +- src/Rlp/Parse/Types.hs | 60 +++++++++++++++++++++++++++++------ 4 files changed, 71 insertions(+), 20 deletions(-) diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index 5967b45..627dcf8 100644 --- a/src/Control/Monad/Errorful.hs +++ b/src/Control/Monad/Errorful.hs @@ -1,6 +1,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TupleSections, PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} module Control.Monad.Errorful ( ErrorfulT , runErrorfulT @@ -11,11 +12,12 @@ module Control.Monad.Errorful ) where ---------------------------------------------------------------------------------- +import Control.Monad.State.Strict import Control.Monad.Trans import Data.Functor.Identity import Data.Coerce -import Data.HashSet (HashSet) -import Data.HashSet qualified as H +import Data.HashSet (HashSet) +import Data.HashSet qualified as H import Lens.Micro ---------------------------------------------------------------------------------- @@ -68,3 +70,10 @@ mapErrorful f (ErrorfulT m) = ErrorfulT $ -- mapErrorful f = coerced . mapped . _2 . mappd %~ f -- lol +-------------------------------------------------------------------------------- +-- daily dose of n^2 instances + +instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where + addWound = undefined + addFatal = undefined + diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index 6fd2428..ccbb65e 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -7,12 +7,14 @@ module Rlp.Lex , RlpToken(..) , Located(..) , lexToken + , lexStream , lexDebug , lexCont ) where import Codec.Binary.UTF8.String (encodeChar) import Control.Monad +import Control.Monad.Errorful import Core.Syntax (Name) import Data.Functor.Identity import Data.Char (digitToInt) @@ -203,13 +205,6 @@ alexEOF = do inp <- getInput pure (Located undefined TokenEOF) -execP :: P a -> ParseState -> Maybe a -execP p st = runP p st & snd - -execP' :: P a -> Text -> Maybe a -execP' p s = execP p st where - st = initParseState s - initParseState :: Text -> ParseState initParseState s = ParseState { _psLayoutStack = [] @@ -228,6 +223,10 @@ initAlexInput s = AlexInput , _aiPos = (1,1) } +runP' :: P a -> Text -> (ParseState, [RlpParseError], Maybe a) +runP' p s = runP p st where + st = initParseState s + lexToken :: P (Located RlpToken) lexToken = do inp <- getInput @@ -242,6 +241,7 @@ lexToken = do AlexToken inp' l act -> do psInput .= inp' act inp l + AlexError inp' -> addFatal RlpParErrLexical lexCont :: (Located RlpToken -> P a) -> P a lexCont = (lexToken >>=) @@ -260,7 +260,7 @@ lexDebug k = do k t lexTest :: Text -> Maybe [RlpToken] -lexTest s = execP' lexStream s +lexTest s = runP' lexStream s ^. _3 indentLevel :: P Int indentLevel = do diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index edc4874..3871a4f 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -161,7 +161,7 @@ mkProgram ds = do pure $ RlpProgram (associate pt <$> ds) parseError :: Located RlpToken -> P a -parseError = error . show +parseError (Located ((l,c),s) t) = addFatal RlpParErrUnknown mkInfixD :: Assoc -> Int -> Name -> P PartialDecl' mkInfixD a p n = do diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 718a9e5..d0f9be2 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -1,11 +1,42 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} {-# LANGUAGE LambdaCase #-} -module Rlp.Parse.Types where +module Rlp.Parse.Types + ( LexerAction + , AlexInput(..) + , Position(..) + , RlpToken(..) + , P(..) + , ParseState(..) + , psLayoutStack + , psLexState + , psInput + , psOpTable + , Layout(..) + , Located(..) + , OpTable + , OpInfo + , RlpParseError(..) + , PartialDecl' + , Partial(..) + , pL, pR + , PartialE + , pattern WithInfo + , opInfoOrDef + , PartialExpr' + , aiPrevChar + , aiSource + , aiBytes + , aiPos + , addFatal + , addWound + ) + where -------------------------------------------------------------------------------- import Core.Syntax (Name) import Control.Monad -import Control.Monad.State.Class +import Control.Monad.State.Strict +import Control.Monad.Errorful import Data.Text (Text) import Data.Maybe import Data.Fix @@ -71,24 +102,31 @@ data RlpToken | TokenEOF deriving (Show) -newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) } +newtype P a = P { runP :: ParseState -> (ParseState, [RlpParseError], Maybe a) } deriving (Functor) instance Applicative P where - pure a = P $ \st -> (st,Just a) + pure a = P $ \st -> (st, [], pure a) liftA2 = liftM2 instance Monad P where p >>= k = P $ \st -> - let (st',a) = runP p st - in case a of - Just x -> runP (k x) st' - Nothing -> (st', Nothing) + let (st',es,ma) = runP p st + in case ma of + Just a -> runP (k a) st' + & _2 %~ (es<>) + Nothing -> (st',es,Nothing) + + {-# INLINE (>>=) #-} instance MonadState ParseState P where state f = P $ \st -> let (a,st') = f st - in (st', Just a) + in (st', [], Just a) + +instance MonadErrorful RlpParseError P where + addWound e = P $ \st -> (st, [e], Just ()) + addFatal e = P $ \st -> (st, [e], Nothing) data ParseState = ParseState { _psLayoutStack :: [Layout] @@ -112,6 +150,8 @@ type OpInfo = (Assoc, Int) data RlpParseError = RlpParErrOutOfBoundsPrecedence Int | RlpParErrDuplicateInfixD + | RlpParErrLexical + | RlpParErrUnknown deriving (Eq, Ord, Show) ---------------------------------------------------------------------------------- @@ -161,3 +201,5 @@ type PartialExpr' = Fix Partial makeLenses ''AlexInput makeLenses ''ParseState +-------------------------------------------------------------------------------- +