Show source line in parse error

1 files changed, 20 insertions, 11 deletions

diff --git a/src/Parser.hs b/src/Parser.hs
index 1746eca..76cc10e 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -30,6 +30,7 @@ import Control.Monad.State.Lazy
 import Data.Char
 import Data.Either (partitionEithers)
 import Data.Foldable
+import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.These
 
@@ -58,6 +59,7 @@ data PS = PS
 
 data Context = Context
   { ctxFile :: FilePath
+  , ctxLines :: [String]  -- ^ The file contents, split up in lines
   , ctxStack :: [String]  -- ^ Stack of syntax scopes, for error reporting
   }
   deriving (Show)
@@ -156,17 +158,23 @@ data ErrMsg = ErrMsg
   { errFile :: FilePath
   , errStk :: [String]
   , errPos :: Pos
-  , errMsg :: String }
+  , errMsg :: String
+  , errSourceLine :: String }
   deriving (Show)
 
 printErrMsg :: ErrMsg -> String
-printErrMsg (ErrMsg fp stk (Pos y x) s) =
-  unlines (map (\descr -> "In " ++ descr ++ ":") (reverse stk)) ++
-  fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s
+printErrMsg (ErrMsg fp stk (Pos y x) s srcline) =
+  let linenum = show (y + 1)
+  in intercalate "\n" $
+      map (\descr -> "In " ++ descr ++ ":") (reverse stk)
+      ++ [fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s
+         ,map (\_ -> ' ') linenum ++ " |"
+         ,linenum ++ " | " ++ srcline
+         ,map (\_ -> ' ') linenum ++ " | " ++ replicate x ' ' ++ "^"]
 
 parse :: FilePath -> String -> These [ErrMsg] (Program ())
 parse fp source =
-  runParser pProgram (Context fp []) (PS (Pos 0 0) (Pos 0 0) source)
+  runParser pProgram (Context fp (lines source) []) (PS (Pos 0 0) (Pos 0 0) source)
     (\_ errs res -> case errs of
                       [] -> That res
                       _ -> These errs res)
@@ -551,10 +559,11 @@ pEVarOrCon0 =
 pEParens0 :: FParser (Expr ())
 pEParens0 = do
   char '('
-  e <- pExpr
-  inlineWhite
-  char ')'
-  return e
+  noFail $ do
+    e <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
+    inlineWhite
+    char ')' <|>> raise Error "Expected closing ')'"
+    return e
 
 data Associativity = AssocLeft | AssocRight | AssocNone
   deriving (Show, Eq)
@@ -813,8 +822,8 @@ raise fat msg = gets psCur >>= \pos -> raiseAt pos fat msg
 -- | Raise an error with the given fatality and description.
 raiseAt :: (KnownFallible fail, FatalCtx fatal a) => Pos -> Fatality fatal -> String -> Parser fail a
 raiseAt pos fat msg = do
-  Context { ctxFile = fp , ctxStack = stk } <- ask
-  let err = ErrMsg fp stk pos msg
+  Context { ctxFile = fp , ctxStack = stk, ctxLines = srcLines } <- ask
+  let err = ErrMsg fp stk pos msg (srcLines !! posLine pos)
   case fat of
     Error -> dictate (pure err)
     Fatal -> confess (pure err)