From 3a7c4a238fffc3714c0948bb5251dcd29c7924cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:19:15 -0400 Subject: [PATCH 1/9] =?UTF-8?q?Produce=20errors=20at=20the=20current=20nod?= =?UTF-8?q?e=E2=80=99s=20location=20instead=20of=20the=20end=20of=20the=20?= =?UTF-8?q?previous=20node.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This gives us better localization of errors, pointing at the start of the (guaranteed extant) current node instead of the state’s current location (which can be an arbitrary distance earlier in the source). --- src/Data/Syntax/Assignment.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index f1268ba60..b2963227a 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -240,7 +240,8 @@ assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Folda assignAllFrom toNode assignment state = case runAssignment toNode assignment state of Result err (Just (a, state)) -> case stateNodes (dropAnonymous toNode state) of [] -> pure (a, state) - node : _ -> Result (err <|> Just (Error (statePos state) (UnexpectedSymbol [] (nodeSymbol (toNode (F.project node)))))) Nothing + node : _ -> let Node nodeSymbol _ (Info.Span spanStart _) = toNode (F.project node) in + Result (err <|> Just (Error spanStart (UnexpectedSymbol [] nodeSymbol))) Nothing r -> r -- | Run an assignment of nodes in a grammar onto terms in a syntax. From 8354b701ae9f4b7b40e1caf5f8fb215da1691126 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:20:02 -0400 Subject: [PATCH 2/9] Alternating results preserves errors. --- src/Data/Syntax/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index b2963227a..70f52bdb0 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -351,7 +351,7 @@ instance Applicative (Result grammar) where instance Alternative (Result grammar) where empty = Result Nothing Nothing - Result e (Just a) <|> _ = Result e (Just a) + Result e1 (Just a) <|> Result e2 _ = Result (e1 <|> e2) (Just a) Result e1 Nothing <|> Result e2 b = Result (e1 <|> e2) b instance MonadError (Error grammar) (Assignment ast grammar) where From a07726fcf3b4d6e59259b1ece63f0ee65fc9db2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:22:27 -0400 Subject: [PATCH 3/9] Preserve errors through repetitions. --- src/Data/Syntax/Assignment.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 70f52bdb0..691a5cf73 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -258,7 +258,8 @@ runAssignment toNode = iterFreer run . fmap ((pure .) . (,)) Result err Nothing -> Result err Nothing (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state (Many _, []) -> yield [] state - (Many rule, _) -> uncurry yield (runMany rule state) + (Many rule, _) -> let (e1, values, state') = runMany rule state + Result e2 v = yield values state' in Result (e1 <|> e2) v -- Nullability: some rules, e.g. @pure a@ and @many a@, should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input. (Alt a b, _) -> yield a state <|> yield b state (Throw e, _) -> Result (Just e) Nothing @@ -274,10 +275,10 @@ runAssignment toNode = iterFreer run . fmap ((pure .) . (,)) Choose choices -> choiceSymbols choices _ -> [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices - runMany :: Assignment ast grammar v -> AssignmentState ast -> ([v], AssignmentState ast) + runMany :: Assignment ast grammar v -> AssignmentState ast -> (Maybe (Error grammar), [v], AssignmentState ast) runMany rule state = case runAssignment toNode rule state of - Result _ (Just (a, state')) -> let (as, state'') = runMany rule state' in as `seq` (a : as, state'') - _ -> ([], state) + Result e1 (Just (a, state')) -> let (e2, as, state'') = runMany rule state' in as `seq` (e1 <|> e2, a : as, state'') + Result err Nothing -> (err, [], state) {-# INLINE run #-} dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast -> AssignmentState ast From 36801584e09d9cb692f0b02cec19b824347e2bf7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:51:42 -0400 Subject: [PATCH 4/9] Prefer the later error. --- src/Data/Syntax/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 691a5cf73..a698cbea6 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -259,7 +259,7 @@ runAssignment toNode = iterFreer run . fmap ((pure .) . (,)) (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state (Many _, []) -> yield [] state (Many rule, _) -> let (e1, values, state') = runMany rule state - Result e2 v = yield values state' in Result (e1 <|> e2) v + Result e2 v = yield values state' in Result (e2 <|> e1) v -- Nullability: some rules, e.g. @pure a@ and @many a@, should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input. (Alt a b, _) -> yield a state <|> yield b state (Throw e, _) -> Result (Just e) Nothing @@ -277,7 +277,7 @@ runAssignment toNode = iterFreer run . fmap ((pure .) . (,)) choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices runMany :: Assignment ast grammar v -> AssignmentState ast -> (Maybe (Error grammar), [v], AssignmentState ast) runMany rule state = case runAssignment toNode rule state of - Result e1 (Just (a, state')) -> let (e2, as, state'') = runMany rule state' in as `seq` (e1 <|> e2, a : as, state'') + Result e1 (Just (a, state')) -> let (e2, as, state'') = runMany rule state' in as `seq` (e2 <|> e1, a : as, state'') Result err Nothing -> (err, [], state) {-# INLINE run #-} From d997779bdf2540ddf381190a8ecd8930f5ebaef0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:52:17 -0400 Subject: [PATCH 5/9] Traverse the Maybe directly. --- src/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parser.hs b/src/Parser.hs index 22e8c1654..bdcacfcc9 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -78,7 +78,7 @@ runParser parser = case parser of AssignmentParser parser by assignment -> \ source -> do ast <- runParser parser source let Result err term = assignBy by assignment source ast - traverse_ (printError source) (toList err) + traverse_ (printError source) err pure $! fromMaybe (errorTerm source) term TreeSitterParser language tslanguage -> treeSitterParser language tslanguage MarkdownParser -> pure . cmarkParser From dcb1794cfa31f13545d4c32297eaf1e0bb9c1467 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:55:13 -0400 Subject: [PATCH 6/9] Print the callstack in white. --- src/Data/Syntax/Assignment.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index a698cbea6..6246c4e7e 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -196,7 +196,8 @@ printError :: Show grammar => Source.Source -> Error grammar -> IO () printError source error@Error{..} = do withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . showPos Nothing errorPos . showString ": " $ "" withSGRCode [SetColor Foreground Vivid Red] . putStrErr . showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" - withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' . showString (prettyCallStack callStack) $ "" + withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' $ "" + putStrErr . showString (prettyCallStack callStack) $ "" where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) From 1b117ef8b0da80a811a766138ccaed24ed342cde Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:55:39 -0400 Subject: [PATCH 7/9] Add a newline after the callstack. --- src/Data/Syntax/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 6246c4e7e..6d8c14750 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -197,7 +197,7 @@ printError source error@Error{..} = do withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . showPos Nothing errorPos . showString ": " $ "" withSGRCode [SetColor Foreground Vivid Red] . putStrErr . showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' $ "" - putStrErr . showString (prettyCallStack callStack) $ "" + putStrErr . showString (prettyCallStack callStack) . showChar '\n' $ "" where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) From 1c1349ef82bcfe49ba0324a7efbdf109393cd87c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:56:40 -0400 Subject: [PATCH 8/9] Apply the ShowS in putStrErr. --- src/Data/Syntax/Assignment.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 6d8c14750..4a43189c7 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -194,14 +194,14 @@ data ErrorCause grammar -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Source.Source -> Error grammar -> IO () printError source error@Error{..} = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . showPos Nothing errorPos . showString ": " $ "" - withSGRCode [SetColor Foreground Vivid Red] . putStrErr . showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" - withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' $ "" - putStrErr . showString (prettyCallStack callStack) . showChar '\n' $ "" + withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos Nothing errorPos . showString ": " + withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') + withSGRCode [SetColor Foreground Vivid Green] . putStrErr $ showChar '^' . showChar '\n' + putStrErr $ showString (prettyCallStack callStack) . showChar '\n' where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) - putStrErr = hPutStr stderr + putStrErr = hPutStr stderr . ($ "") withSGRCode :: [SGR] -> IO a -> IO () withSGRCode code action = do From 9370addba1d2577448e8dc941ddcd6407deee192 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Jul 2017 12:58:41 -0400 Subject: [PATCH 9/9] Print the source in white. --- src/Data/Syntax/Assignment.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 4a43189c7..a6520ca9a 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -195,7 +195,8 @@ data ErrorCause grammar printError :: Show grammar => Source.Source -> Error grammar -> IO () printError source error@Error{..} = do withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos Nothing errorPos . showString ": " - withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') + withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n' + putStrErr $ showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') withSGRCode [SetColor Foreground Vivid Green] . putStrErr $ showChar '^' . showChar '\n' putStrErr $ showString (prettyCallStack callStack) . showChar '\n' where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ])