Refactor error reporting slightly

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

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]

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

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 ()
 

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

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)
+alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing Nothing

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

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