Implement rendering of parse error context (#236)

AUTHORS.md

@@ -24,6 +24,7 @@ Names below are sorted alphabetically.
 ## Contributors
 
 * Albert Netymk
+* Alex Washburn (@recursion-ninja)
 * Antoine Latter
 * Artyom (@neongreen)
 * Auke Booij

CHANGELOG.md

@@ -66,6 +66,17 @@
   we had something like that in the `hspec-megaparsec` package, but it does
   not hurt to ship it with the library.
 
+* Added `parseErrorPretty'` allowing to display offending line in parse
+  errors.
+
+* Added `LineToken` type class for tokens that support operations necessary
+  for selecting and displaying relevant line of input (used in
+  `parseErrorPretty'`).
+
+* Added `parseTest'` function that is just like `parseTest`, but also prints
+  offending line in parse errors. This is powered by the new
+  `parseErrorPretty'`.
+
 ### Stream
 
 * Introduced the new `Text.Megaparsec.Stream` module that is the home of

Text/Megaparsec.hs

@@ -72,6 +72,7 @@ module Text.Megaparsec
   , parse
   , parseMaybe
   , parseTest
+  , parseTest'
   , runParser
   , runParser'
   , runParserT
@@ -474,6 +475,24 @@ parseTest p input =
     Left  e -> putStr (parseErrorPretty e)
     Right x -> print x
 
+-- | A version of 'parseTest' that also prints offending line in parse
+-- errors.
+--
+-- @since 6.0.0
+
+parseTest' :: ( ShowErrorComponent e
+              , ShowToken (Token s)
+              , LineToken (Token s)
+              , Show a
+              , Stream s )
+  => Parsec e s a -- ^ Parser to run
+  -> s            -- ^ Input for parser
+  -> IO ()
+parseTest' p input =
+  case parse p "" input of
+    Left  e -> putStr (parseErrorPretty' input e)
+    Right x -> print x
+
 -- | @'runParser' p file input@ runs parser @p@ on the input stream of
 -- tokens @input@, obtained from source @file@. The @file@ is only used in
 -- error messages and may be the empty string. Returns either a 'ParseError'

Text/Megaparsec/Error.hs

@@ -15,21 +15,27 @@
 -- You probably do not want to import this module directly because
 -- "Text.Megaparsec" re-exports it anyway.
 
-{-# LANGUAGE CPP                #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor      #-}
-{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DeriveDataTypeable  #-}
+{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Text.Megaparsec.Error
-  ( ErrorItem (..)
+  ( -- * Parse error type
+    ErrorItem (..)
   , ErrorFancy (..)
   , ParseError (..)
   , errorPos
+    -- * Pretty-printing
   , ShowToken (..)
+  , LineToken (..)
   , ShowErrorComponent (..)
   , parseErrorPretty
+  , parseErrorPretty'
   , sourcePosStackPretty
   , parseErrorTextPretty )
 where
@@ -41,6 +47,7 @@ import Data.Data (Data)
 import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (fromMaybe, isNothing)
+import Data.Proxy
 import Data.Semigroup
 import Data.Set (Set)
 import Data.Typeable (Typeable)
@@ -49,13 +56,17 @@ import Data.Word (Word8)
 import GHC.Generics
 import Prelude hiding (concat)
 import Text.Megaparsec.Pos
+import Text.Megaparsec.Stream
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Set           as E
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
 #endif
 
+----------------------------------------------------------------------------
+-- Parse error type
+
 -- | Data type that is used to represent “unexpected\/expected” items in
 -- 'ParseError'. The data type is parametrized over the token type @t@.
 --
@@ -184,6 +195,9 @@ mergeError e1 e2 =
     n (Just x) (Just y) = Just (max x y)
 {-# INLINE mergeError #-}
 
+----------------------------------------------------------------------------
+-- Pretty-printing
+
 -- | Type class 'ShowToken' includes methods that allow to pretty-print
 -- single token as well as stream of tokens. This is used for rendering of
 -- error messages.
@@ -203,6 +217,30 @@ instance ShowToken Char where
 instance ShowToken Word8 where
   showTokens = stringPretty . fmap (chr . fromIntegral)
 
+-- | Type class for tokens that support operations necessary for selecting
+-- and displaying relevant line of input.
+--
+-- @since 6.0.0
+
+class LineToken a where
+
+  -- | Convert a token to a 'Char'. This is used to print relevant line from
+  -- input stream by turning a list of tokens into a 'String'.
+
+  tokenAsChar :: a -> Char
+
+  -- | Check if given token is a newline or contains newline.
+
+  tokenIsNewline :: a -> Bool
+
+instance LineToken Char where
+  tokenAsChar = id
+  tokenIsNewline x = x == '\n'
+
+instance LineToken Word8 where
+  tokenAsChar = chr . fromIntegral
+  tokenIsNewline x = x == 10
+
 -- | The type class defines how to print custom data component of
 -- 'ParseError'.
 --
@@ -248,6 +286,42 @@ parseErrorPretty
 parseErrorPretty e =
   sourcePosStackPretty (errorPos e) <> ":\n" <> parseErrorTextPretty e
 
+-- | Pretty-print a 'ParseError' and display the line on which the parse
+-- error occurred. The rendered 'String' always ends with a newline.
+--
+-- Note that if you work with include files and have a stack of
+-- 'SourcePos'es in 'ParseError', it's up to you to provide correct input
+-- stream corresponding to the file in which parse error actually happened.
+--
+-- @since 6.0.0
+
+parseErrorPretty'
+  :: forall s e.
+     ( ShowToken (Token s)
+     , LineToken (Token s)
+     , ShowErrorComponent e
+     , Stream s )
+  => s                 -- ^ Original input stream
+  -> ParseError (Token s) e -- ^ Parse error to render
+  -> String             -- ^ Result of rendering
+parseErrorPretty' s e =
+  sourcePosStackPretty (errorPos e) <> ":\n" <>
+    padding <> "|\n" <>
+    lineNumber <> " | " <> rline <> "\n" <>
+    padding <> "| " <> rpadding <> "^\n" <>
+    parseErrorTextPretty e
+  where
+    epos       = NE.last (errorPos e)
+    lineNumber = (show . unPos . sourceLine) epos
+    padding    = replicate (length lineNumber + 1) ' '
+    rpadding   = replicate (unPos (sourceColumn epos) - 1) ' '
+    rline      =
+      case rline' of
+        [] -> "<empty line>"
+        xs -> xs
+    rline'     = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $
+      selectLine (sourceLine epos) s
+
 -- | Pretty-print a stack of source positions.
 --
 -- @since 5.0.0
@@ -363,3 +437,18 @@ orList :: NonEmpty String -> String
 orList (x:|[])  = x
 orList (x:|[y]) = x <> " or " <> y
 orList xs       = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs
+
+-- | Select a line from input stream given its number.
+
+selectLine
+  :: (LineToken (Token s), Stream s)
+  => Pos               -- ^ Number of line to select
+  -> s                 -- ^ Input stream
+  -> Tokens s          -- ^ Selected line
+selectLine l = go pos1
+  where
+    go !n !s =
+      if n == l
+        then fst (takeWhile_ notNewline s)
+        else go (n <> pos1) (snd (takeWhile_ notNewline s))
+    notNewline = not . tokenIsNewline

Text/Megaparsec/Stream.hs

@@ -281,5 +281,5 @@ defaultAdvance1 width (SourcePos n l c) t = npos
       case fromEnum t of
         10 -> SourcePos n (l <> pos1) pos1
         9  -> SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))
-        _   -> SourcePos n l (c <> pos1)
+        _  -> SourcePos n l (c <> pos1)
 {-# INLINE defaultAdvance1 #-}

tests/Text/Megaparsec/ErrorSpec.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Text.Megaparsec.ErrorSpec (spec) where
 
+import Data.ByteString (ByteString)
 import Data.Char (isControl, isSpace)
 import Data.List (isInfixOf, isSuffixOf)
 import Data.List.NonEmpty (NonEmpty (..))
@@ -14,6 +16,7 @@ import Test.QuickCheck
 import Text.Megaparsec.Error
 import Text.Megaparsec.Error.Builder
 import Text.Megaparsec.Pos
+import qualified Data.ByteString    as B
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Semigroup     as S
 import qualified Data.Set           as E
@@ -26,6 +29,7 @@ import Control.Exception (Exception (..))
 #endif
 
 type PE = ParseError Char Void
+type PW = ParseError Word8 Void
 
 spec :: Spec
 spec = do
@@ -88,7 +92,8 @@ spec = do
             FancyError   pos _   -> pos)
 
   describe "showTokens (Char instance)" $ do
-    let f x y = showTokens (NE.fromList x) `shouldBe` y
+    let f :: String -> String -> Expectation
+        f x y = showTokens (NE.fromList x) `shouldBe` y
     it "shows CRLF newline correctly"
       (f "\r\n" "crlf newline")
     it "shows null byte correctly"
@@ -207,6 +212,39 @@ spec = do
             mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")
       parseErrorPretty pe `shouldBe` "1:1:\nbar\nfoo\n"
 
+  describe "parseErrorPretty'" $ do
+    context "with Char tokens" $ do
+      it "shows empty line correctly" $ do
+        let s = "" :: String
+        parseErrorPretty' s (mempty :: PE) `shouldBe`
+          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"
+      it "shows position on first line correctly" $ do
+        let s = "abc" :: String
+            pe = err (posN 1 s) (utok 'b' <> etok 'd') :: PE
+        parseErrorPretty' s pe `shouldBe`
+          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"
+      it "shows position on 1000 line correctly" $ do
+        let s = replicate 999 '\n' ++ "abc"
+            pe :: PE
+            pe = err (posN 999 s) (utok 'a' <> etok 'd')
+        parseErrorPretty' s pe `shouldBe`
+          "1000:1:\n     |\n1000 | <empty line>\n     | ^\nunexpected 'a'\nexpecting 'd'\n"
+    context "with Word8 tokens" $ do
+      it "shows empty line correctly" $ do
+        let s = "" :: ByteString
+        parseErrorPretty' s (mempty :: PW) `shouldBe`
+          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"
+      it "shows position on first line correctly" $ do
+        let s = "abc" :: ByteString
+            pe = err (posN 1 s) (utok 98 <> etok 100) :: PW
+        parseErrorPretty' s pe `shouldBe`
+          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"
+      it "shows position on 1000 line correctly" $ do
+        let s = B.replicate 999 10 <> "abc"
+            pe = err (posN 999 s) (utok 97 <> etok 100) :: PW
+        parseErrorPretty' s pe `shouldBe`
+          "1000:1:\n     |\n1000 | <empty line>\n     | ^\nunexpected 'a'\nexpecting 'd'\n"
+
   describe "sourcePosStackPretty" $
     it "result never ends with a newline " $
       property $ \x ->