amelia
/
ahc
1
0
Fork 0
Code Issues 0 Pull Requests 0 Projects 0 Releases 0 Wiki Activity
Browse Source

Refactor error reporting slightly

master
Amélia Liao 2 years ago
parent
238511c99d
commit
b189c96a39
8 changed files with 217 additions and 112 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +2
    -1
      ahc.cabal
  2. +99
    -0
      src/Errors.hs
  3. +1
    -1
      src/Frontend/Autogen/Lexer.x
  4. +64
    -12
      src/Frontend/Autogen/Parser.y
  5. +3
    -3
      src/Frontend/Lexer/Tokens.hs
  6. +15
    -20
      src/Frontend/Lexer/Wrapper.hs
  7. +31
    -30
      src/Frontend/Parser/Foreign.hs
  8. +2
    -45
      src/Main.hs

+ 2
- 1
ahc.cabal View File

@ -31,7 +31,8 @@ executable ahc
Frontend.Lexer.Wrapper, Frontend.Lexer.Wrapper,
Frontend.Parser.Posn, Frontend.Parser.Posn,
Frontend.Parser.Foreign, Frontend.Parser.Foreign,
Frontend.Syntax
Frontend.Syntax,
Errors
build-tool-depends: alex:alex >= 3.2.4 && < 4.0 build-tool-depends: alex:alex >= 3.2.4 && < 4.0
, happy:happy >= 1.19.12 && < 2.0 , happy:happy >= 1.19.12 && < 2.0

+ 99
- 0
src/Errors.hs View File

@ -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]

+ 1
- 1
src/Frontend/Autogen/Lexer.x View File

@ -408,7 +408,7 @@ finishVarKw l c text = do
when (sc /= foreign_) $ pushStartCode foreign_ when (sc /= foreign_) $ pushStartCode foreign_
pure (Token TokForeign l c) 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 "safe" -> conditionalKeyword l c foreign_ (c > col) TokSafe
"unsafe" -> conditionalKeyword l c foreign_ (c > col) TokUnsafe "unsafe" -> conditionalKeyword l c foreign_ (c > col) TokUnsafe
"ccall" -> conditionalKeyword l c foreign_ (c > col) TokCCall "ccall" -> conditionalKeyword l c foreign_ (c > col) TokCCall


+ 64
- 12
src/Frontend/Autogen/Parser.y View File

@ -18,9 +18,11 @@ import Prelude hiding (span)
import Debug.Trace import Debug.Trace
import Control.Monad import Control.Monad
import Errors
} }
%name parseExp Exp
%name exp Exp
%name parseMod Module %name parseMod Module
%name parseType Type %name parseType Type
@ -212,6 +214,38 @@ FfiItem :: { FfiItem ParsedVar }
, fiBegin = startPosn $1 , fiBegin = startPosn $1
, fiEnd = endPosn $7 } , 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 } Safety :: { Maybe FfiSafety }
: {-empty-} { Nothing } : {-empty-} { Nothing }
@ -220,6 +254,20 @@ Safety :: { Maybe FfiSafety }
CallConv :: { FfiCallConv } CallConv :: { FfiCallConv }
: 'ccall' { CC_CCall } : '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 } Entity :: { Maybe Token }
: {-empty-} { Nothing } : {-empty-} { Nothing }
@ -327,15 +375,19 @@ type Rhs = FeRhs ParsedVar
type Module = FeModule ParsedVar type Module = FeModule ParsedVar
type Item = ModuleItem 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 parseError (token, expected) = do
(here, _, _, _) <- alexGetInput (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 makeLams xs b = foldr Lam b xs
@ -385,11 +437,11 @@ spanModuleItems xs = do
forM_ items $ \x -> case x of forM_ items $ \x -> case x of
ModImport _ start end -> ModImport _ start end ->
alexThrow $ \fname -> 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 () _ -> pure ()


+ 3
- 3
src/Frontend/Lexer/Tokens.hs View File

@ -103,9 +103,9 @@ instance Show TokenClass where
show TokForeign = "foreign" show TokForeign = "foreign"
show TokExport = "export" 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 :: TokenClass -> Bool
isKeywordToken TokLet = True isKeywordToken TokLet = True


+ 15
- 20
src/Frontend/Lexer/Wrapper.hs View File

@ -2,14 +2,16 @@ module Frontend.Lexer.Wrapper where
import Control.Applicative as App (Applicative (..)) 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.Word (Word8)
import Data.Int (Int64) 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 Frontend.Lexer.Tokens (Token)
import qualified Data.Text as T
import Frontend.Parser.Posn import Frontend.Parser.Posn
type Byte = Word8 type Byte = Word8
@ -66,7 +68,7 @@ data AlexState = AlexState {
, alex_fname :: String , 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) = runAlex fname input__ (Alex f) =
case f initState of case f initState of
Left msg -> Left msg Left msg -> Left msg
@ -84,7 +86,7 @@ runAlex fname input__ (Alex f) =
, alex_fname = fname , 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 instance Functor Alex where
fmap f a = Alex $ \s -> case unAlex a s of fmap f a = Alex $ \s -> case unAlex a s of
@ -121,12 +123,12 @@ alexSetInput (pos,c,inp__,bpos)
, ()) , ())
alexError :: String -> Alex a 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 :: 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)) alexThrow err = Alex $ \s -> Left (err (alex_fname s))
alexGetStartCode :: Alex Int alexGetStartCode :: Alex Int
@ -166,16 +168,9 @@ data AlexUserState =
, stringBuffer :: !T.Text , stringBuffer :: !T.Text
, stringStartPosn :: Maybe Posn , stringStartPosn :: Maybe Posn
, lastToken :: Maybe Token
} }
alexInitUserState :: AlexUserState 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)
alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing Nothing

+ 31
- 30
src/Frontend/Parser/Foreign.hs View File

@ -14,6 +14,7 @@ import Frontend.Syntax
import Text.Show.Pretty import Text.Show.Pretty
import Frontend.Parser.Posn import Frontend.Parser.Posn
import Data.Char (isAlpha) import Data.Char (isAlpha)
import Errors
parseForeignItem :: Token -> Alex FfiImpEnt parseForeignItem :: Token -> Alex FfiImpEnt
parseForeignItem token@(Token (TokString impent) line col) = go 0 impent emptyItem 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 -> Int -> Int -> Alex a
tooManyHeaders (Posn l c) off len = tooManyHeaders (Posn l c) off len =
alexThrow $ \fname -> 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 -> Int -> Int -> Alex a
tooManyItemNames (Posn l c) off len = tooManyItemNames (Posn l c) off len =
alexThrow $ \fname -> 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 -> Int -> Alex a
tooManyReferences (Posn l c) off = tooManyReferences (Posn l c) off =
alexThrow $ \fname -> 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 -> Int -> Alex a
tooManyStatics (Posn l c) off = tooManyStatics (Posn l c) off =
alexThrow $ \fname -> 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) parseCid :: Posn -> Int -> T.Text -> Alex (Maybe T.Text)
@ -101,12 +102,12 @@ parseCid (Posn l c) off id
| isValidCIdent id = pure $ Just id | isValidCIdent id = pure $ Just id
| otherwise = | otherwise =
alexThrow $ \fname -> 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 isValidCIdent :: T.Text -> Bool


+ 2
- 45
src/Main.hs View File

@ -23,6 +23,7 @@ import System.Posix.Internals
import GHC.IO.Handle.FD (stdout, handleToFd) import GHC.IO.Handle.FD (stdout, handleToFd)
import GHC.IO.FD import GHC.IO.FD
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Errors
main :: IO () main :: IO ()
main = do main = do
@ -45,54 +46,10 @@ lex fname show cont arg = do
then pure . lines $ T.unpack (T.decodeUtf8 (Lbs.toStrict arg)) then pure . lines $ T.unpack (T.decodeUtf8 (Lbs.toStrict arg))
else lines <$> readFile fname else lines <$> readFile fname
case x of case x of
Left e -> putStr $ showParseError color code e
Left e -> putStr $ showAhcError color code e
Right x -> show x 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 :: [Token] -> Alex [Token]
scan acc = do scan acc = do


Write Preview
Loading…
Cancel
Save