src/Compiler/RLPC.hs

@@ -18,6 +18,7 @@ module Compiler.RLPC
     , RLPCOptions(RLPCOptions)
     , IsRlpcError(..)
     , RlpcError(..)
+    , MsgEnvelope(..)
     , addFatal
     , addWound
     , MonadErrorful

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
+    }
+

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 >>=)

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  -> addWoundHere l e >> pure (Just o) where
-        Just o  -> pure (Just o)
+            e = RlpParErrDuplicateInfixD n
+            l = T.length n
         Nothing -> pure (Just (a,p))
         )
     pure $ InfixD a p n
+
 }

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)
+