diff --git a/rlp.cabal b/rlp.cabal index d2b278b..b813073 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -73,6 +73,7 @@ library , semigroupoids , comonad , lens + , text-ansi hs-source-dirs: src default-language: GHC2021 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 474ecfc..48fdfab 100644 --- a/src/Compiler/RLPC.hs +++ b/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 = ["", "", ""] + filename = msgColour "" + 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) diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 3a94275..79b7d8a 100644 --- a/src/Compiler/Types.hs +++ b/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 diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index 627dcf8..f767b99 100644 --- a/src/Control/Monad/Errorful.hs +++ b/src/Control/Monad/Errorful.hs @@ -3,9 +3,9 @@ {-# LANGUAGE TupleSections, PatternSynonyms #-} {-# LANGUAGE UndecidableInstances #-} module Control.Monad.Errorful - ( ErrorfulT - , runErrorfulT + ( ErrorfulT(..) , 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 -------------------------------------------------------------------------------- diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index 72f2cf0..adc30f5 100644 --- a/src/Rlp/Lex.x +++ b/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] + } diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 789c517..a885f59 100644 --- a/src/Rlp/Parse.y +++ b/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 } + diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 903c574..77c6519 100644 --- a/src/Rlp/Parse/Types.hs +++ b/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) + } +