diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index a4b3556..2993c67 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -18,6 +18,7 @@ module Compiler.RLPC , RLPCOptions(RLPCOptions) , IsRlpcError(..) , RlpcError(..) + , MsgEnvelope(..) , addFatal , addWound , MonadErrorful diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index 2d748af..ae3751d 100644 --- a/src/Compiler/RlpcError.hs +++ b/src/Compiler/RlpcError.hs @@ -3,13 +3,14 @@ module Compiler.RlpcError ( IsRlpcError(..) , MsgEnvelope(..) - , Severity + , Severity(..) , RlpcError(..) , SrcSpan(..) , msgSpan , msgDiagnostic , msgSeverity , liftRlpcErrors + , errorMsg ) where ---------------------------------------------------------------------------------- @@ -60,3 +61,10 @@ liftRlpcErrors = mapErrorful liftRlpcError instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError +errorMsg :: SrcSpan -> e -> MsgEnvelope e +errorMsg s e = MsgEnvelope + { _msgSpan = s + , _msgDiagnostic = e + , _msgSeverity = SevError + } + diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index ccbb65e..6942b84 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -54,6 +54,7 @@ $asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] @reservedname = case|data|do|import|in|let|letrec|module|of|where + |infixr|infixl|infix @reservedop = "=" | \\ | "->" | "|" @@ -125,6 +126,9 @@ lexReservedName = \case "of" -> TokenOf "let" -> TokenLet "in" -> TokenIn + "infix" -> TokenInfix + "infixl" -> TokenInfixL + "infixr" -> TokenInfixR lexReservedOp :: Text -> RlpToken lexReservedOp = \case @@ -223,7 +227,7 @@ initAlexInput s = AlexInput , _aiPos = (1,1) } -runP' :: P a -> Text -> (ParseState, [RlpParseError], Maybe a) +runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) runP' p s = runP p st where st = initParseState s @@ -241,7 +245,7 @@ lexToken = do AlexToken inp' l act -> do psInput .= inp' act inp l - AlexError inp' -> addFatal RlpParErrLexical + AlexError inp' -> addFatalHere 1 RlpParErrLexical lexCont :: (Located RlpToken -> P a) -> P a lexCont = (lexToken >>=) diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index e96db59..444a6d4 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -4,6 +4,7 @@ module Rlp.Parse ( parseRlpProg ) where +import Compiler.RlpcError import Rlp.Lex import Rlp.Syntax import Rlp.Parse.Types @@ -14,6 +15,7 @@ import Lens.Micro.Platform () import Data.List.Extra import Data.Fix import Data.Functor.Const +import Data.Text qualified as T } %name parseRlpProg StandaloneProgram @@ -161,16 +163,19 @@ mkProgram ds = do pure $ RlpProgram (associate pt <$> ds) parseError :: Located RlpToken -> P a -parseError (Located ((l,c),s) t) = addFatal RlpParErrUnexpectedToken +parseError (Located ((l,c),s) t) = addFatal $ + errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken mkInfixD :: Assoc -> Int -> Name -> P PartialDecl' mkInfixD a p n = do let opl :: Lens' ParseState (Maybe OpInfo) opl = psOpTable . at n opl <~ (use opl >>= \case - -- TODO: non-fatal error - Just o -> pure (Just o) + Just o -> addWoundHere l e >> pure (Just o) where + e = RlpParErrDuplicateInfixD n + l = T.length n Nothing -> pure (Just (a,p)) ) pure $ InfixD a p n + } diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 498335f..bddf0d9 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -3,6 +3,8 @@ {-# LANGUAGE LambdaCase #-} module Rlp.Parse.Types ( LexerAction + , MsgEnvelope(..) + , RlpcError(..) , AlexInput(..) , Position(..) , RlpToken(..) @@ -30,6 +32,8 @@ module Rlp.Parse.Types , aiPos , addFatal , addWound + , addFatalHere + , addWoundHere ) where -------------------------------------------------------------------------------- @@ -66,6 +70,12 @@ type Position = , Int -- column ) +posLine :: Lens' Position Int +posLine = _1 + +posColumn :: Lens' Position Int +posColumn = _2 + data RlpToken -- literals = TokenLitInt Int @@ -103,7 +113,10 @@ data RlpToken | TokenEOF deriving (Show) -newtype P a = P { runP :: ParseState -> (ParseState, [RlpParseError], Maybe a) } +newtype P a = P { + runP :: ParseState + -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) + } deriving (Functor) instance Applicative P where @@ -125,7 +138,7 @@ instance MonadState ParseState P where let (a,st') = f st in (st', [], Just a) -instance MonadErrorful RlpParseError P where +instance MonadErrorful (MsgEnvelope RlpParseError) P where addWound e = P $ \st -> (st, [e], Just ()) addFatal e = P $ \st -> (st, [e], Nothing) @@ -150,7 +163,7 @@ type OpInfo = (Assoc, Int) -- data WithLocation a = WithLocation [String] a data RlpParseError = RlpParErrOutOfBoundsPrecedence Int - | RlpParErrDuplicateInfixD + | RlpParErrDuplicateInfixD Name | RlpParErrLexical | RlpParErrUnexpectedToken deriving (Eq, Ord, Show) @@ -158,7 +171,6 @@ data RlpParseError = RlpParErrOutOfBoundsPrecedence Int instance IsRlpcError RlpParseError where ---------------------------------------------------------------------------------- - -- absolute psycho shit (partial ASTs) type PartialDecl' = Decl (Const PartialExpr') Name @@ -204,3 +216,27 @@ type PartialExpr' = Fix Partial makeLenses ''AlexInput makeLenses ''ParseState +addWoundHere :: Int -> RlpParseError -> P () +addWoundHere l e = P $ \st -> + let e' = MsgEnvelope + { _msgSpan = let pos = psInput . aiPos + in SrcSpan (st ^. pos . posLine) + (st ^. pos . posColumn) + l + , _msgDiagnostic = e + , _msgSeverity = SevError + } + in (st, [e'], Just ()) + +addFatalHere :: Int -> RlpParseError -> P a +addFatalHere l e = P $ \st -> + let e' = MsgEnvelope + { _msgSpan = let pos = psInput . aiPos + in SrcSpan (st ^. pos . posLine) + (st ^. pos . posColumn) + l + , _msgDiagnostic = e + , _msgSeverity = SevError + } + in (st, [e'], Nothing) +