error messages

rlp.cabal

@@ -73,6 +73,7 @@ library
                     , semigroupoids
                     , comonad
                     , lens
+                    , text-ansi
 
     hs-source-dirs:   src
     default-language: GHC2021

src/Compiler/RLPC.hs

@@ -46,6 +46,7 @@ import Control.Monad.Reader
 import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
 import Compiler.RlpcError
+import Compiler.Types
 import Data.Functor.Identity
 import Data.Default.Class
 import Data.Foldable
@@ -55,6 +56,10 @@ import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
 import Data.HashSet             qualified as S
 import Data.Coerce
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Text.ANSI                qualified as Ansi
+import Text.PrettyPrint         hiding ((<>))
 import Lens.Micro.Platform
 import System.Exit
 ----------------------------------------------------------------------------------
@@ -79,7 +84,9 @@ evalRLPCT :: (Monad m)
           => RLPCOptions
           -> RLPCT m a
           -> m (Maybe a, [MsgEnvelope RlpcError])
-evalRLPCT = undefined
+evalRLPCT opt r = runRLPCT r
+                & flip runReaderT opt
+                & runErrorfulT
 
 evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
 evalRLPCIO opt r = do
@@ -90,7 +97,33 @@ evalRLPCIO opt r = do
         Nothing -> die "Failed, no code compiled."
 
 putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs = traverse_ print
+putRlpcErrs = traverse_ (putStrLn . ('\n':) . render . prettyRlpcErr)
+
+prettyRlpcErr :: MsgEnvelope RlpcError -> Doc
+prettyRlpcErr msg = header
+                 $$ nest 2 bullets
+                 $$ source
+    where
+        source = vcat $ zipWith (<+>) rule srclines
+            where
+                rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
+                srclines = ["", "<problematic source code>", ""]
+        filename = msgColour "<input>"
+        pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
+                       <> ":"
+                       <> tshow (msg ^. msgSpan . srcspanColumn)
+
+        header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
+                        <> errorColour "error" <> msgColour ":"
+
+        bullets = let Text ts = msg ^. msgDiagnostic
+                  in vcat $ hang "•" 2 . ttext . msgColour <$> ts
+
+        msgColour = Ansi.white . Ansi.bold
+        errorColour = Ansi.red . Ansi.bold
+        ttext = text . T.unpack
+        tshow :: (Show a) => a -> Text
+        tshow = T.pack . show
 
 liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
 liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)

src/Compiler/Types.hs

@@ -1,5 +1,6 @@
 module Compiler.Types
     ( SrcSpan(..)
+    , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
     , Located(..)
     , (<<~), (<~>)
 
@@ -13,6 +14,7 @@ module Compiler.Types
 import Control.Comonad
 import Data.Functor.Apply
 import Data.Functor.Bind
+import Control.Lens             hiding ((<<~))
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
@@ -39,6 +41,16 @@ data SrcSpan = SrcSpan
     !Int -- ^ Length
     deriving Show
 
+tupling :: Iso' SrcSpan (Int, Int, Int, Int)
+tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
+              (\ (a,b,c,d) -> SrcSpan a b c d)
+
+srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
+srcspanLine = tupling . _1
+srcspanColumn = tupling . _2
+srcspanAbs = tupling . _3
+srcspanLen = tupling . _4
+
 instance Semigroup SrcSpan where
     SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
         l = min la lb

src/Control/Monad/Errorful.hs

@@ -3,9 +3,9 @@
 {-# LANGUAGE TupleSections, PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
-    ( ErrorfulT
+    ( ErrorfulT(..)
-    , runErrorfulT
     , Errorful
+    , pattern Errorful
     , runErrorful
     , mapErrorful
     , MonadErrorful(..)
@@ -67,7 +67,7 @@ mapErrorful f (ErrorfulT m) = ErrorfulT $
     m & mapped . _2 . mapped %~ f
 
 -- when microlens-pro drops we can write this as
---    mapErrorful f = coerced . mapped . _2 . mappd %~ f
+--    mapErrorful f = coerced . mapped . _2 . mapped %~ f
 -- lol
 
 --------------------------------------------------------------------------------

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 RlpToken, [String]) -> P a
-parseError (Located ss t) = addFatal $
+parseError ((Located ss t), exp) = addFatal $
-    errorMsg ss RlpParErrUnexpectedToken
+    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
+                   | RlpParErrUnexpectedToken RlpToken [String]
-                   deriving (Eq, Ord, Show)
+                   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)
+    }
+