{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Megaparsec.Error
(
ErrorItem (..)
, ErrorFancy (..)
, ParseError (..)
, errorPos
, ShowToken (..)
, LineToken (..)
, ShowErrorComponent (..)
, parseErrorPretty
, parseErrorPretty'
, parseErrorPretty_
, sourcePosStackPretty
, parseErrorTextPretty )
where
import Control.DeepSeq
import Control.Exception
import Data.Char (chr)
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)
import Data.Void
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
data ErrorItem t
= Tokens (NonEmpty t)
| Label (NonEmpty Char)
| EndOfInput
deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)
instance NFData t => NFData (ErrorItem t)
data ErrorFancy e
= ErrorFail String
| ErrorIndentation Ordering Pos Pos
| ErrorCustom e
deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)
instance NFData a => NFData (ErrorFancy a) where
rnf (ErrorFail str) = rnf str
rnf (ErrorIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act
rnf (ErrorCustom a) = rnf a
data ParseError t e
= TrivialError (NonEmpty SourcePos) (Maybe (ErrorItem t)) (Set (ErrorItem t))
| FancyError (NonEmpty SourcePos) (Set (ErrorFancy e))
deriving (Show, Read, Eq, Data, Typeable, Generic)
instance (NFData t, NFData e) => NFData (ParseError t e)
instance (Ord t, Ord e) => Semigroup (ParseError t e) where
(<>) = mergeError
{-# INLINE (<>) #-}
instance (Ord t, Ord e) => Monoid (ParseError t e) where
mempty = TrivialError (initialPos "" :| []) Nothing E.empty
mappend = (<>)
{-# INLINE mappend #-}
instance ( Show t
, Ord t
, ShowToken t
, Typeable t
, Show e
, ShowErrorComponent e
, Typeable e )
=> Exception (ParseError t e) where
#if MIN_VERSION_base(4,8,0)
displayException = parseErrorPretty
#endif
errorPos :: ParseError t e -> NonEmpty SourcePos
errorPos (TrivialError p _ _) = p
errorPos (FancyError p _) = p
mergeError :: (Ord t, Ord e)
=> ParseError t e
-> ParseError t e
-> ParseError t e
mergeError e1 e2 =
case errorPos e1 `compare` errorPos e2 of
LT -> e2
EQ ->
case (e1, e2) of
(TrivialError s1 u1 p1, TrivialError _ u2 p2) ->
TrivialError s1 (n u1 u2) (E.union p1 p2)
(FancyError {}, TrivialError {}) -> e1
(TrivialError {}, FancyError {}) -> e2
(FancyError s1 x1, FancyError _ x2) ->
FancyError s1 (E.union x1 x2)
GT -> e1
where
n Nothing Nothing = Nothing
n (Just x) Nothing = Just x
n Nothing (Just y) = Just y
n (Just x) (Just y) = Just (max x y)
{-# INLINE mergeError #-}
class ShowToken a where
showTokens :: NonEmpty a -> String
instance ShowToken Char where
showTokens = stringPretty
instance ShowToken Word8 where
showTokens = stringPretty . fmap (chr . fromIntegral)
class LineToken a where
tokenAsChar :: a -> Char
tokenIsNewline :: a -> Bool
instance LineToken Char where
tokenAsChar = id
tokenIsNewline x = x == '\n'
instance LineToken Word8 where
tokenAsChar = chr . fromIntegral
tokenIsNewline x = x == 10
class Ord a => ShowErrorComponent a where
showErrorComponent :: a -> String
instance (Ord t, ShowToken t) => ShowErrorComponent (ErrorItem t) where
showErrorComponent (Tokens ts) = showTokens ts
showErrorComponent (Label label) = NE.toList label
showErrorComponent EndOfInput = "end of input"
instance ShowErrorComponent e => ShowErrorComponent (ErrorFancy e) where
showErrorComponent (ErrorFail msg) = msg
showErrorComponent (ErrorIndentation ord ref actual) =
"incorrect indentation (got " <> show (unPos actual) <>
", should be " <> p <> show (unPos ref) <> ")"
where
p = case ord of
LT -> "less than "
EQ -> "equal to "
GT -> "greater than "
showErrorComponent (ErrorCustom a) = showErrorComponent a
instance ShowErrorComponent Void where
showErrorComponent = absurd
parseErrorPretty
:: ( Ord t
, ShowToken t
, ShowErrorComponent e )
=> ParseError t e
-> String
parseErrorPretty e =
sourcePosStackPretty (errorPos e) <> ":\n" <> parseErrorTextPretty e
parseErrorPretty'
:: ( ShowToken (Token s)
, LineToken (Token s)
, ShowErrorComponent e
, Stream s )
=> s
-> ParseError (Token s) e
-> String
parseErrorPretty' = parseErrorPretty_ defaultTabWidth
parseErrorPretty_
:: forall s e.
( ShowToken (Token s)
, LineToken (Token s)
, ShowErrorComponent e
, Stream s )
=> Pos
-> s
-> ParseError (Token s) e
-> String
parseErrorPretty_ w 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 -> expandTab w xs
rline' = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $
selectLine (sourceLine epos) s
sourcePosStackPretty :: NonEmpty SourcePos -> String
sourcePosStackPretty ms = mconcat (f <$> rest) <> sourcePosPretty pos
where
(pos :| rest') = ms
rest = reverse rest'
f p = "in file included from " <> sourcePosPretty p <> ",\n"
parseErrorTextPretty
:: ( Ord t
, ShowToken t
, ShowErrorComponent e )
=> ParseError t e
-> String
parseErrorTextPretty (TrivialError _ us ps) =
if isNothing us && E.null ps
then "unknown parse error\n"
else messageItemsPretty "unexpected " (maybe E.empty E.singleton us) <>
messageItemsPretty "expecting " ps
parseErrorTextPretty (FancyError _ xs) =
if E.null xs
then "unknown fancy parse error\n"
else unlines (showErrorComponent <$> E.toAscList xs)
stringPretty :: NonEmpty Char -> String
stringPretty (x:|[]) = charPretty x
stringPretty ('\r':|"\n") = "crlf newline"
stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\""
where
f ch =
case charPretty' ch of
Nothing -> [ch]
Just pretty -> "<" <> pretty <> ">"
charPretty :: Char -> String
charPretty ' ' = "space"
charPretty ch = fromMaybe ("'" <> [ch] <> "'") (charPretty' ch)
charPretty' :: Char -> Maybe String
charPretty' '\NUL' = pure "null"
charPretty' '\SOH' = pure "start of heading"
charPretty' '\STX' = pure "start of text"
charPretty' '\ETX' = pure "end of text"
charPretty' '\EOT' = pure "end of transmission"
charPretty' '\ENQ' = pure "enquiry"
charPretty' '\ACK' = pure "acknowledge"
charPretty' '\BEL' = pure "bell"
charPretty' '\BS' = pure "backspace"
charPretty' '\t' = pure "tab"
charPretty' '\n' = pure "newline"
charPretty' '\v' = pure "vertical tab"
charPretty' '\f' = pure "form feed"
charPretty' '\r' = pure "carriage return"
charPretty' '\SO' = pure "shift out"
charPretty' '\SI' = pure "shift in"
charPretty' '\DLE' = pure "data link escape"
charPretty' '\DC1' = pure "device control one"
charPretty' '\DC2' = pure "device control two"
charPretty' '\DC3' = pure "device control three"
charPretty' '\DC4' = pure "device control four"
charPretty' '\NAK' = pure "negative acknowledge"
charPretty' '\SYN' = pure "synchronous idle"
charPretty' '\ETB' = pure "end of transmission block"
charPretty' '\CAN' = pure "cancel"
charPretty' '\EM' = pure "end of medium"
charPretty' '\SUB' = pure "substitute"
charPretty' '\ESC' = pure "escape"
charPretty' '\FS' = pure "file separator"
charPretty' '\GS' = pure "group separator"
charPretty' '\RS' = pure "record separator"
charPretty' '\US' = pure "unit separator"
charPretty' '\DEL' = pure "delete"
charPretty' '\160' = pure "non-breaking space"
charPretty' _ = Nothing
messageItemsPretty :: ShowErrorComponent a
=> String
-> Set a
-> String
messageItemsPretty prefix ts
| E.null ts = ""
| otherwise =
let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent
in prefix <> f ts <> "\n"
orList :: NonEmpty String -> String
orList (x:|[]) = x
orList (x:|[y]) = x <> " or " <> y
orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs
selectLine
:: forall s. (LineToken (Token s), Stream s)
=> Pos
-> s
-> Tokens s
selectLine l = go pos1
where
go !n !s =
if n == l
then fst (takeWhile_ notNewline s)
else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s))
notNewline = not . tokenIsNewline
stripNewline s =
case take1_ s of
Nothing -> s
Just (_, s') -> s'
expandTab
:: Pos
-> String
-> String
expandTab w' = go 0
where
go 0 [] = []
go 0 ('\t':xs) = go w xs
go 0 (x:xs) = x : go 0 xs
go !n xs = ' ' : go (n - 1) xs
w = unPos w'