module Text.Megaparsec.Error
( ErrorItem (..)
, ErrorComponent (..)
, Dec (..)
, ParseError (..)
, ShowToken (..)
, ShowErrorComponent (..)
, parseErrorPretty
, sourcePosStackPretty )
where
import Control.DeepSeq
import Control.Monad.Catch
import Data.Data (Data)
import Data.Foldable (concat)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Semigroup
import Data.Set (Set)
import Data.Typeable (Typeable)
import GHC.Generics
import Prelude hiding (concat)
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as E
import Text.Megaparsec.Pos
#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)
instance NFData t => NFData (ErrorItem t)
class Ord e => ErrorComponent e where
representFail :: String -> e
representIndentation
:: Ordering
-> Pos
-> Pos
-> e
data Dec
= DecFail String
| DecIndentation Ordering Pos Pos
deriving (Show, Read, Eq, Ord, Data, Typeable)
instance NFData Dec where
rnf (DecFail str) = rnf str
rnf (DecIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act
instance ErrorComponent Dec where
representFail = DecFail
representIndentation = DecIndentation
data ParseError t e = ParseError
{ errorPos :: NonEmpty SourcePos
, errorUnexpected :: Set (ErrorItem t)
, errorExpected :: Set (ErrorItem t)
, errorCustom :: Set 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
instance (Ord t, Ord e) => Monoid (ParseError t e) where
mempty = ParseError (initialPos "" :| []) E.empty E.empty E.empty
mappend = (<>)
instance (Show t, Typeable t, Show e, Typeable e) => Exception (ParseError t e)
mergeError :: (Ord t, Ord e)
=> ParseError t e
-> ParseError t e
-> ParseError t e
mergeError e1@(ParseError pos1 u1 p1 x1) e2@(ParseError pos2 u2 p2 x2) =
case pos1 `compare` pos2 of
LT -> e2
EQ -> ParseError pos1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2)
GT -> e1
class ShowToken a where
showTokens :: NonEmpty a -> String
instance ShowToken Char where
showTokens = stringPretty
stringPretty :: NonEmpty Char -> String
stringPretty (x:|[]) = charPretty x
stringPretty ('\r':|"\n") = "crlf newline"
stringPretty xs = "\"" ++ NE.toList xs ++ "\""
charPretty :: Char -> String
charPretty '\0' = "null"
charPretty '\a' = "bell"
charPretty '\b' = "backspace"
charPretty '\t' = "tab"
charPretty '\n' = "newline"
charPretty '\v' = "vertical tab"
charPretty '\f' = "form feed"
charPretty '\r' = "carriage return"
charPretty ' ' = "space"
charPretty x = "'" ++ [x] ++ "'"
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 Dec where
showErrorComponent (DecFail msg) = msg
showErrorComponent (DecIndentation 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 "
parseErrorPretty :: ( Ord t
, ShowToken t
, ShowErrorComponent e )
=> ParseError t e
-> String
parseErrorPretty (ParseError pos us ps xs) =
sourcePosStackPretty pos ++ ":\n" ++
if E.null us && E.null ps && E.null xs
then "unknown parse error\n"
else concat
[ messageItemsPretty "unexpected " us
, messageItemsPretty "expecting " ps
, unlines (showErrorComponent <$> E.toAscList xs) ]
sourcePosStackPretty :: NonEmpty SourcePos -> String
sourcePosStackPretty ms = concatMap f rest ++ sourcePosPretty pos
where (pos :| rest') = ms
rest = reverse rest'
f p = "in file included from " ++ sourcePosPretty p ++ ",\n"
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