error messages

src/Rlp/Lex.x

@@ -11,6 +11,8 @@ module Rlp.Lex
     , lexDebug
     , lexCont
     , popLexState
+    , programInitState
+    , runP'
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -236,27 +238,9 @@ alexEOF = do
     pos <- getPos
     pure (Located (spanFromPos pos 0) TokenEOF)
 
-initParseState :: Text -> ParseState
-initParseState s = ParseState
-    { _psLayoutStack = []
-    -- IMPORTANT: the initial state is `bol` to begin the top-level layout,
-    -- which then returns to state 0 which continues the normal lexing process.
-    , _psLexState = [layout_top,0]
-    , _psInput = initAlexInput s
-    , _psOpTable = mempty
-    }
-
-initAlexInput :: Text -> AlexInput
-initAlexInput s = AlexInput
-    { _aiPrevChar   = '\0'
-    , _aiSource     = s
-    , _aiBytes      = []
-    , _aiPos        = (1,1,0)
-    }
-
 runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
 runP' p s = runP p st where
-    st = initParseState s
+    st = initParseState [layout_top,0] s
 
 lexToken :: P (Located RlpToken)
 lexToken = do
@@ -310,7 +294,7 @@ popLayout = do
     psLayoutStack %= (drop 1)
     case ctx of
         Just l      -> pure l
-        Nothing     -> error "uhh"
+        Nothing     -> error "popLayout: layout stack empty! this is a bug."
 
 pushLayout :: Layout -> P ()
 pushLayout l = do
@@ -368,10 +352,13 @@ explicitRBrace inp l = do
 doLayout :: LexerAction (Located RlpToken)
 doLayout _ _ = do
     i <- indentLevel
-    traceM $ "doLayout: i: " <> show i
+    -- traceM $ "doLayout: i: " <> show i
     pushLayout (Implicit i)
     popLexState
     insertLBrace
 
+programInitState :: Text -> ParseState
+programInitState = initParseState [layout_top,0]
+
 }
 

src/Rlp/Parse.y

@@ -2,10 +2,13 @@
 {-# LANGUAGE LambdaCase, ViewPatterns #-}
 module Rlp.Parse
     ( parseRlpProg
+    , parseRlpProgR
     , parseRlpExpr
+    , parseRlpExprR
     )
     where
 import Compiler.RlpcError
+import Compiler.RLPC
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
@@ -19,6 +22,7 @@ import Data.Functor.Bind
 import Control.Comonad
 import Data.Functor
 import Data.Semigroup.Traversable
+import Data.Text                    (Text)
 import Data.Text                    qualified as T
 import Data.Void
 }
@@ -29,6 +33,7 @@ import Data.Void
 %monad { P }
 %lexer { lexCont } { Located _ TokenEOF }
 %error { parseError }
+%errorhandlertype explist
 %tokentype { Located RlpToken }
 
 %token
@@ -85,6 +90,7 @@ DeclsV              :: { [Decl' RlpcPs] }
 DeclsV              : Decl VS Decls         { $1 : $3 }
                     | Decl VS               { [$1] }
                     | Decl                  { [$1] }
+                    | {- epsilon -}         { [] }
 
 VS                  :: { Located RlpToken }
 VS                  : ';'                   { $1 }
@@ -187,6 +193,13 @@ Con         :: { Located PsName }
 
 {
 
+parseRlpExprR = undefined
+
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
+parseRlpProgR s = liftErrorful $ pToErrorful parseRlpProg st
+    where
+        st = programInitState s
+
 mkPsName :: Located RlpToken -> Located PsName
 mkPsName = fmap extractName
 
@@ -207,9 +220,9 @@ mkProgram ds = do
     pt <- use psOpTable
     pure $ RlpProgram (associate pt <$> ds)
 
-parseError :: Located RlpToken -> P a
-parseError (Located ss t) = addFatal $
-    errorMsg ss RlpParErrUnexpectedToken
+parseError :: (Located RlpToken, [String]) -> P a
+parseError ((Located ss t), exp) = addFatal $
+    errorMsg ss (RlpParErrUnexpectedToken t exp)
 
 mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
 mkInfixD a p n = do
@@ -228,3 +241,4 @@ intOfToken :: Located RlpToken -> Int
 intOfToken (Located _ (TokenLitInt n)) = n
 
 }
+

src/Rlp/Parse/Types.hs

@@ -8,6 +8,8 @@ module Rlp.Parse.Types
 
     -- * Parser monad and state
     , P(..), ParseState(..), Layout(..), OpTable, OpInfo
+    , initParseState, initAlexInput
+    , pToErrorful
     -- ** Lenses
     , psLayoutStack, psLexState, psInput, psOpTable
 
@@ -39,6 +41,7 @@ import Data.Functor.Classes
 import Data.HashMap.Strict          qualified as H
 import Data.Void
 import Data.Word                    (Word8)
+import Data.Text                    qualified as T
 import Lens.Micro.TH
 import Lens.Micro
 import Rlp.Syntax
@@ -145,6 +148,11 @@ newtype P a = P {
     }
     deriving (Functor)
 
+pToErrorful :: (Applicative m)
+            => P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a
+pToErrorful p st = ErrorfulT $ pure (ma,es) where
+    (_,es,ma) = runP p st
+
 instance Applicative P where
     pure a = P $ \st -> (st, [], pure a)
     liftA2 = liftM2
@@ -188,10 +196,28 @@ type OpInfo = (Assoc, Int)
 data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
                    | RlpParErrDuplicateInfixD Name
                    | RlpParErrLexical
-                   | RlpParErrUnexpectedToken
-                   deriving (Eq, Ord, Show)
+                   | RlpParErrUnexpectedToken RlpToken [String]
+                   deriving (Show)
 
 instance IsRlpcError RlpParseError where
+    liftRlpcError = \case
+        RlpParErrOutOfBoundsPrecedence n ->
+            Text [ "Illegal precedence in infixity declaration"
+                 , "rl' currently only allows precedences between 0 and 9."
+                 ]
+        RlpParErrDuplicateInfixD s ->
+            Text [ "Conflicting infixity declarations for operator "
+                    <> tshow s
+                 ]
+        RlpParErrLexical ->
+            Text [ "Unknown lexical error :(" ]
+        RlpParErrUnexpectedToken t exp ->
+            Text [ "Unexpected token " <> tshow t
+                 , "Expected: " <> tshow exp
+                 ]
+        where
+            tshow :: (Show a) => a -> T.Text
+            tshow = T.pack . show
 
 ----------------------------------------------------------------------------------
 
@@ -224,3 +250,21 @@ addFatalHere l e = P $ \st ->
             }
     in (st, [e'], Nothing)
 
+initParseState :: [Int] -> Text -> ParseState
+initParseState ls s = ParseState
+    { _psLayoutStack = []
+    -- IMPORTANT: the initial state is `bol` to begin the top-level layout,
+    -- which then returns to state 0 which continues the normal lexing process.
+    , _psLexState = ls
+    , _psInput = initAlexInput s
+    , _psOpTable = mempty
+    }
+
+initAlexInput :: Text -> AlexInput
+initAlexInput s = AlexInput
+    { _aiPrevChar   = '\0'
+    , _aiSource     = s
+    , _aiBytes      = []
+    , _aiPos        = (1,1,0)
+    }
+