From b189c96a39b3e75cc1826f789b3b2503a46178f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Abigail=20Magalh=C3=A3es?= Date: Tue, 3 Aug 2021 23:42:15 -0300 Subject: [PATCH] Refactor error reporting slightly --- ahc.cabal | 3 +- src/Errors.hs | 99 ++++++++++++++++++++++++++++++++++ src/Frontend/Autogen/Lexer.x | 2 +- src/Frontend/Autogen/Parser.y | 76 +++++++++++++++++++++----- src/Frontend/Lexer/Tokens.hs | 6 +-- src/Frontend/Lexer/Wrapper.hs | 35 ++++++------ src/Frontend/Parser/Foreign.hs | 61 ++++++++++----------- src/Main.hs | 47 +--------------- 8 files changed, 217 insertions(+), 112 deletions(-) create mode 100644 src/Errors.hs diff --git a/ahc.cabal b/ahc.cabal index 3c98c64..df62fe4 100644 --- a/ahc.cabal +++ b/ahc.cabal @@ -31,7 +31,8 @@ executable ahc Frontend.Lexer.Wrapper, Frontend.Parser.Posn, Frontend.Parser.Foreign, - Frontend.Syntax + Frontend.Syntax, + Errors build-tool-depends: alex:alex >= 3.2.4 && < 4.0 , happy:happy >= 1.19.12 && < 2.0 diff --git a/src/Errors.hs b/src/Errors.hs new file mode 100644 index 0000000..5d98d52 --- /dev/null +++ b/src/Errors.hs @@ -0,0 +1,99 @@ +module Errors where + +import Frontend.Parser.Posn +import Data.Maybe +import qualified GHC.IO.Handle.FD +import System.Posix.Internals (c_isatty) +import GHC.IO.FD + +data AhcError + = AhcError { errorMessage :: String + , errorFilename :: String + , errorInlineDesc :: Maybe String + , errorBegin :: Posn + , errorEnd :: Posn + , errorPointers :: [ErrorPointer] + } + deriving (Eq, Show) + +emptyError :: AhcError +emptyError = + AhcError (error "parse errors must have a message") + (error "parse errors must have a filename") + Nothing + (error "parse errors must have a start pos") + (error "parse errors must have an end pos") + [] + +data ErrorPointer + = ErrorPointer { errorPointerBegin :: Posn + , errorPointerEnd :: Posn + , errorPointerNote :: Maybe String + , errorPointerDrawSquiggle :: Bool + } + deriving (Eq, Show) + +showAhcError :: Bool -> [String] -> AhcError -> String +showAhcError color code pe = do + unlines $ + [ bold + ++ errorFilename pe + ++ ":" ++ show linum ++ ":" ++ show startcol ++ ": " + ++ red ++ "parse error:" ++ reset + + ] ++ map (render bold red sep reset) (mainPointer:errorPointers pe) ++ + [ padToMax "" ++ " " ++ errorMessage pe + ] + where + linum = posnLine (errorBegin pe) + startcol = posnColm (errorBegin pe) + + maxln = maximum [ length (show (posnLine e)) | e <- errorEnd pe:map errorPointerEnd (errorPointers pe)] + + (red, bold, reset, sep) + | color = ("\x1b[31m", "\x1b[1m", "\x1b[0m", "\x1b[1;34m \9474 \x1b[0m") + | otherwise = ("", "", "", "") + + padToMax x + | length x < maxln = replicate (maxln - length x) ' ' ++ x + | otherwise = x + + mainPointer = ErrorPointer (errorBegin pe) (errorEnd pe) (errorInlineDesc pe) True + + render bold red sep reset (ErrorPointer start end note squig) = do + let + linum = posnLine start + startcol = posnColm start + + multiline = linum /= posnLine end + + width + | multiline = 0 + | otherwise = max 0 (posnColm (errorEnd pe) - startcol - 1) + + linum' = padToMax $ show linum + + line = [ show linum ++ sep ++ code !! (linum - 1) | linum <- [ linum .. posnLine (errorEnd pe) ] ] + + padding = replicate (length linum') ' ' ++ sep + padding' = replicate (length linum') ' ' ++ " " + + caret = replicate (startcol - 1) ' ' ++ red ++ "^" + squiggle + | squig = replicate width '~' + | otherwise = "" + + init $ unlines + [ padding + , init (unlines line) + , padding ++ caret ++ squiggle ++ reset ++ fromMaybe "" ((" " ++) <$> note) + ] + +printParseError :: AhcError -> IO () +printParseError pe = do + code <- lines <$> readFile (errorFilename pe) + color <- fmap (1 ==) . c_isatty . fdFD =<< GHC.IO.Handle.FD.handleToFd GHC.IO.Handle.FD.stdout + putStr $ showAhcError color code pe + +pointTo :: HasPosn x => x -> x -> String -> [ErrorPointer] +pointTo s e msg = [ErrorPointer (startPosn s) (endPosn e) (Just msg) False] \ No newline at end of file diff --git a/src/Frontend/Autogen/Lexer.x b/src/Frontend/Autogen/Lexer.x index 8bede11..975c471 100644 --- a/src/Frontend/Autogen/Lexer.x +++ b/src/Frontend/Autogen/Lexer.x @@ -408,7 +408,7 @@ finishVarKw l c text = do when (sc /= foreign_) $ pushStartCode foreign_ pure (Token TokForeign l c) - "export" -> conditionalKeyword l c foreign_ (c > col) TokForeign + "export" -> conditionalKeyword l c foreign_ (c > col) TokExport "safe" -> conditionalKeyword l c foreign_ (c > col) TokSafe "unsafe" -> conditionalKeyword l c foreign_ (c > col) TokUnsafe "ccall" -> conditionalKeyword l c foreign_ (c > col) TokCCall diff --git a/src/Frontend/Autogen/Parser.y b/src/Frontend/Autogen/Parser.y index a408d45..a03aa53 100644 --- a/src/Frontend/Autogen/Parser.y +++ b/src/Frontend/Autogen/Parser.y @@ -18,9 +18,11 @@ import Prelude hiding (span) import Debug.Trace import Control.Monad + +import Errors } -%name parseExp Exp +%name exp Exp %name parseMod Module %name parseType Type @@ -212,6 +214,38 @@ FfiItem :: { FfiItem ParsedVar } , fiBegin = startPosn $1 , fiEnd = endPosn $7 } } } + | 'import' CallConv VAR error + {% do { state <- getUserState + ; (here, _, _, _) <- alexGetInput + ; let vartk = $3 + ; case lastToken state of + Just tok -> alexThrow $ \fn -> + emptyError { errorMessage = "malformed foreign import (did you spell safe/unsafe incorrectly?)" + , errorInlineDesc = Just "this token was interpreted as a variable name" + , errorBegin = startPosn vartk + , errorEnd = startPosn vartk + , errorFilename = fn + , errorPointers = pointTo tok tok "so this token should have been part of a type signature" + } + Nothing -> alexError "no last token?" + } + } + | 'export' CallConv Entity VAR '::' Type + -- 1 2 3 4 5 6 + {% do { ffiDesc <- + case $3 of + Nothing -> pure Nothing + Just x -> + let Posn l c = startPosn x + in parseCid (Posn l (c + 1)) 0 (getString x) + ; pure $ FfiExport + { fiVarName = getVar $4 + , fiType = $6 + , fiCallConv = $2 + , fiExpCid = ffiDesc + , fiBegin = startPosn $1 + , fiEnd = endPosn $6 } + } } Safety :: { Maybe FfiSafety } : {-empty-} { Nothing } @@ -220,6 +254,20 @@ Safety :: { Maybe FfiSafety } CallConv :: { FfiCallConv } : 'ccall' { CC_CCall } + | error + {% do { state <- getUserState + ; (here, _, _, _) <- alexGetInput + ; case lastToken state of + Just tok -> alexThrow $ \fn -> + emptyError { errorMessage = "ahc only supports the 'ccall' calling convention" + , errorInlineDesc = Just ("unexpected " ++ show (tokenClass tok)) + , errorBegin = startPosn tok + , errorEnd = here + , errorFilename = fn + } + Nothing -> alexError "no last token?" + } + } Entity :: { Maybe Token } : {-empty-} { Nothing } @@ -327,15 +375,19 @@ type Rhs = FeRhs ParsedVar type Module = FeModule ParsedVar type Item = ModuleItem ParsedVar -lexer cont = alexMonadScan >>= cont +lexer cont = do + tok <- alexMonadScan + mapUserState $ \s -> s { lastToken = Just tok } + cont tok parseError (token, expected) = do (here, _, _, _) <- alexGetInput - alexThrow $ \fn -> ParseError { parseErrorMessage = "expecting one of: " ++ unwords expected - , parseErrorInlineDesc = Just ("unexpected " ++ show (tokenClass token)) - , parseErrorBegin = startPosn token - , parseErrorEnd = here - , parseErrorFilename = fn } + alexThrow $ \fn -> emptyError { errorMessage = "expecting one of: " ++ unwords expected + , errorInlineDesc = Just ("unexpected " ++ show (tokenClass token)) + , errorBegin = startPosn token + , errorEnd = here + , errorFilename = fn + } makeLams xs b = foldr Lam b xs @@ -385,11 +437,11 @@ spanModuleItems xs = do forM_ items $ \x -> case x of ModImport _ start end -> alexThrow $ \fname -> - ParseError { parseErrorMessage = "all import statements should be at the top of the file." - , parseErrorInlineDesc = Just "unexpected import statement" - , parseErrorFilename = fname - , parseErrorBegin = start - , parseErrorEnd = end + emptyError { errorMessage = "all import statements should be at the top of the file." + , errorInlineDesc = Just "unexpected import statement" + , errorFilename = fname + , errorBegin = start + , errorEnd = end } _ -> pure () diff --git a/src/Frontend/Lexer/Tokens.hs b/src/Frontend/Lexer/Tokens.hs index f1e08ea..06ed763 100644 --- a/src/Frontend/Lexer/Tokens.hs +++ b/src/Frontend/Lexer/Tokens.hs @@ -103,9 +103,9 @@ instance Show TokenClass where show TokForeign = "foreign" show TokExport = "export" - show TokSafe = "export" - show TokUnsafe = "export" - show TokCCall = "export" + show TokSafe = "safe" + show TokUnsafe = "unsafe" + show TokCCall = "ccall" isKeywordToken :: TokenClass -> Bool isKeywordToken TokLet = True diff --git a/src/Frontend/Lexer/Wrapper.hs b/src/Frontend/Lexer/Wrapper.hs index a035a6a..07e9b25 100644 --- a/src/Frontend/Lexer/Wrapper.hs +++ b/src/Frontend/Lexer/Wrapper.hs @@ -2,14 +2,16 @@ module Frontend.Lexer.Wrapper where import Control.Applicative as App (Applicative (..)) +import qualified Data.ByteString.Internal as ByteString (w2c) +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.Text as T +import qualified Data.Char import Data.Word (Word8) - import Data.Int (Int64) -import qualified Data.Char -import qualified Data.ByteString.Lazy as ByteString -import qualified Data.ByteString.Internal as ByteString (w2c) + +import Errors + import Frontend.Lexer.Tokens (Token) -import qualified Data.Text as T import Frontend.Parser.Posn type Byte = Word8 @@ -66,7 +68,7 @@ data AlexState = AlexState { , alex_fname :: String } -runAlex :: String -> ByteString.ByteString -> Alex a -> Either ParseError a +runAlex :: String -> ByteString.ByteString -> Alex a -> Either AhcError a runAlex fname input__ (Alex f) = case f initState of Left msg -> Left msg @@ -84,7 +86,7 @@ runAlex fname input__ (Alex f) = , alex_fname = fname } -newtype Alex a = Alex { unAlex :: AlexState -> Either ParseError (AlexState, a) } +newtype Alex a = Alex { unAlex :: AlexState -> Either AhcError (AlexState, a) } instance Functor Alex where fmap f a = Alex $ \s -> case unAlex a s of @@ -121,12 +123,12 @@ alexSetInput (pos,c,inp__,bpos) , ()) alexError :: String -> Alex a -alexError message = Alex $ \s -> Left (ParseError message (alex_fname s) Nothing (alex_pos s) (alex_pos s)) +alexError message = Alex $ \s -> Left (AhcError message (alex_fname s) Nothing (alex_pos s) (alex_pos s) []) alexErrorPosn :: Posn -> Posn -> String -> Alex a -alexErrorPosn start end message = Alex $ \s -> Left (ParseError message (alex_fname s) Nothing start end) +alexErrorPosn start end message = Alex $ \s -> Left (AhcError message (alex_fname s) Nothing start end []) -alexThrow :: (String -> ParseError) -> Alex a +alexThrow :: (String -> AhcError) -> Alex a alexThrow err = Alex $ \s -> Left (err (alex_fname s)) alexGetStartCode :: Alex Int @@ -166,16 +168,9 @@ data AlexUserState = , stringBuffer :: !T.Text , stringStartPosn :: Maybe Posn + + , lastToken :: Maybe Token } alexInitUserState :: AlexUserState -alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing - -data ParseError - = ParseError { parseErrorMessage :: String - , parseErrorFilename :: String - , parseErrorInlineDesc :: Maybe String - , parseErrorBegin :: Posn - , parseErrorEnd :: Posn - } - deriving (Eq, Show) \ No newline at end of file +alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing Nothing diff --git a/src/Frontend/Parser/Foreign.hs b/src/Frontend/Parser/Foreign.hs index d60d90e..d9c9e45 100644 --- a/src/Frontend/Parser/Foreign.hs +++ b/src/Frontend/Parser/Foreign.hs @@ -14,6 +14,7 @@ import Frontend.Syntax import Text.Show.Pretty import Frontend.Parser.Posn import Data.Char (isAlpha) +import Errors parseForeignItem :: Token -> Alex FfiImpEnt parseForeignItem token@(Token (TokString impent) line col) = go 0 impent emptyItem @@ -54,45 +55,45 @@ parseForeignItem _ = undefined tooManyHeaders :: Posn -> Int -> Int -> Alex a tooManyHeaders (Posn l c) off len = alexThrow $ \fname -> - ParseError - { parseErrorMessage = "this foreign entity has too many header names; only one is allowed." - , parseErrorFilename = fname - , parseErrorInlineDesc = Just "repeated header name" - , parseErrorBegin = Posn l (c + off) - , parseErrorEnd = Posn l (c + off + len) + emptyError + { errorMessage = "this foreign entity has too many header names; only one is allowed." + , errorFilename = fname + , errorInlineDesc = Just "repeated header name" + , errorBegin = Posn l (c + off) + , errorEnd = Posn l (c + off + len) } tooManyItemNames :: Posn -> Int -> Int -> Alex a tooManyItemNames (Posn l c) off len = alexThrow $ \fname -> - ParseError - { parseErrorMessage = "this foreign entity has too many names; only one is allowed." - , parseErrorFilename = fname - , parseErrorInlineDesc = Just "repeated name" - , parseErrorBegin = Posn l (c + off) - , parseErrorEnd = Posn l (c + off + len) + emptyError + { errorMessage = "this foreign entity has too many names; only one is allowed." + , errorFilename = fname + , errorInlineDesc = Just "repeated name" + , errorBegin = Posn l (c + off) + , errorEnd = Posn l (c + off + len) } tooManyReferences :: Posn -> Int -> Alex a tooManyReferences (Posn l c) off = alexThrow $ \fname -> - ParseError - { parseErrorMessage = "this foreign entity has too many '&'s; only one is allowed." - , parseErrorFilename = fname - , parseErrorInlineDesc = Just "repeated '&'" - , parseErrorBegin = Posn l (c + off) - , parseErrorEnd = Posn l (c + off + 1) + emptyError + { errorMessage = "this foreign entity has too many '&'s; only one is allowed." + , errorFilename = fname + , errorInlineDesc = Just "repeated '&'" + , errorBegin = Posn l (c + off) + , errorEnd = Posn l (c + off + 1) } tooManyStatics :: Posn -> Int -> Alex a tooManyStatics (Posn l c) off = alexThrow $ \fname -> - ParseError - { parseErrorMessage = "this foreign entity has too many 'static's; only one is allowed." - , parseErrorFilename = fname - , parseErrorInlineDesc = Just "repeated 'static'" - , parseErrorBegin = Posn l (c + off) - , parseErrorEnd = Posn l (c + off + length "static") + emptyError + { errorMessage = "this foreign entity has too many 'static's; only one is allowed." + , errorFilename = fname + , errorInlineDesc = Just "repeated 'static'" + , errorBegin = Posn l (c + off) + , errorEnd = Posn l (c + off + length "static") } parseCid :: Posn -> Int -> T.Text -> Alex (Maybe T.Text) @@ -101,12 +102,12 @@ parseCid (Posn l c) off id | isValidCIdent id = pure $ Just id | otherwise = alexThrow $ \fname -> - ParseError - { parseErrorMessage = "names for foreign entities must be valid C identifiers." - , parseErrorFilename = fname - , parseErrorInlineDesc = Just "this is not a C identifier" - , parseErrorBegin = Posn l (c + off) - , parseErrorEnd = Posn l (c + off + T.length id) + emptyError + { errorMessage = "names for foreign entities must be valid C identifiers." + , errorFilename = fname + , errorInlineDesc = Just "this is not a C identifier" + , errorBegin = Posn l (c + off) + , errorEnd = Posn l (c + off + T.length id) } isValidCIdent :: T.Text -> Bool diff --git a/src/Main.hs b/src/Main.hs index 0d9b667..f6dc3b0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -23,6 +23,7 @@ import System.Posix.Internals import GHC.IO.Handle.FD (stdout, handleToFd) import GHC.IO.FD import Data.Maybe (fromMaybe) +import Errors main :: IO () main = do @@ -45,54 +46,10 @@ lex fname show cont arg = do then pure . lines $ T.unpack (T.decodeUtf8 (Lbs.toStrict arg)) else lines <$> readFile fname case x of - Left e -> putStr $ showParseError color code e + Left e -> putStr $ showAhcError color code e Right x -> show x -printParseError :: ParseError -> IO () -printParseError pe = do - code <- lines <$> readFile (parseErrorFilename pe) - color <- fmap (1 ==) . c_isatty . fdFD =<< handleToFd GHC.IO.Handle.FD.stdout - putStr $ showParseError color code pe - -showParseError :: Bool -> [String] -> ParseError -> String -showParseError color code pe = do - let - linum = posnLine (parseErrorBegin pe) - startcol = posnColm (parseErrorBegin pe) - - multiline = linum /= posnLine (parseErrorEnd pe) - - width - | multiline = 0 - | otherwise = max 0 (posnColm (parseErrorEnd pe) - startcol - 1) - - linum' = show linum - - line = [ show linum ++ sep ++ code !! (linum - 1) | linum <- [ linum .. posnLine (parseErrorEnd pe) ] ] - padding = replicate (length linum') ' ' ++ sep - padding' = replicate (length linum') ' ' ++ " " - - caret = replicate (startcol - 1) ' ' ++ red ++ "^" - squiggle = replicate width '~' - - (red, bold, reset, sep) - | color = ("\x1b[31m", "\x1b[1m", "\x1b[0m", "\x1b[1;34m \9474 \x1b[0m") - | otherwise = ("", "", "", "") - - unlines $ - [ bold - ++ parseErrorFilename pe - ++ ":" ++ show linum ++ ":" ++ show startcol ++ ": " - ++ red ++ "parse error:" ++ reset - - , padding' - , init (unlines line) - , padding' ++ caret ++ squiggle ++ reset ++ fromMaybe "" ((" " ++) <$> parseErrorInlineDesc pe) - - , "" - , padding' ++ parseErrorMessage pe - ] scan :: [Token] -> Alex [Token] scan acc = do