errorful parser

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

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

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