module Text.Megaparsec.Error
( Message (..)
, messageString
, badMessage
, ParseError
, errorPos
, errorMessages
, errorIsUnknown
, newErrorMessage
, newErrorMessages
, newErrorUnknown
, addErrorMessage
, addErrorMessages
, setErrorMessage
, setErrorPos
, mergeError
, showMessages )
where
import Control.Exception (Exception)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Typeable (Typeable)
import Text.Megaparsec.Pos
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Foldable (foldMap)
import Data.Monoid
#endif
data Message
= Unexpected !String
| Expected !String
| Message !String
deriving (Show, Eq)
instance Enum Message where
fromEnum (Unexpected _) = 0
fromEnum (Expected _) = 1
fromEnum (Message _) = 2
toEnum _ = error "Text.Megaparsec.Error: toEnum is undefined for Message"
instance Ord Message where
compare m1 m2 =
case compare (fromEnum m1) (fromEnum m2) of
LT -> LT
EQ -> compare (messageString m1) (messageString m2)
GT -> GT
messageString :: Message -> String
messageString (Unexpected s) = s
messageString (Expected s) = s
messageString (Message s) = s
badMessage :: Message -> Bool
badMessage = null . messageString
data ParseError = ParseError
{
errorPos :: !SourcePos
, errorMessages :: [Message] }
deriving (Eq, Typeable)
instance Show ParseError where
show e = show (errorPos e) ++ ":\n" ++ showMessages (errorMessages e)
instance Monoid ParseError where
mempty = newErrorUnknown (initialPos "")
mappend = mergeError
instance Exception ParseError
errorIsUnknown :: ParseError -> Bool
errorIsUnknown (ParseError _ ms) = null ms
newErrorMessage :: Message -> SourcePos -> ParseError
newErrorMessage m = newErrorMessages [m]
newErrorMessages :: [Message] -> SourcePos -> ParseError
newErrorMessages ms pos = addErrorMessages ms $ newErrorUnknown pos
newErrorUnknown :: SourcePos -> ParseError
newErrorUnknown pos = ParseError pos []
addErrorMessage :: Message -> ParseError -> ParseError
addErrorMessage m (ParseError pos ms) =
ParseError pos $ if badMessage m then ms else pre ++ [m] ++ post
where pre = filter (< m) ms
post = filter (> m) ms
addErrorMessages :: [Message] -> ParseError -> ParseError
addErrorMessages ms err = foldr addErrorMessage err ms
setErrorMessage :: Message -> ParseError -> ParseError
setErrorMessage m (ParseError pos ms) =
if badMessage m then err else addErrorMessage m err
where err = ParseError pos xs
xs = filter ((/= fromEnum m) . fromEnum) ms
setErrorPos :: SourcePos -> ParseError -> ParseError
setErrorPos pos (ParseError _ ms) = ParseError pos ms
mergeError :: ParseError -> ParseError -> ParseError
mergeError e1@(ParseError pos1 _) e2@(ParseError pos2 ms2) =
case pos1 `compare` pos2 of
LT -> e2
EQ -> addErrorMessages ms2 e1
GT -> e1
showMessages :: [Message] -> String
showMessages [] = "unknown parse error"
showMessages ms = tail $ foldMap (fromMaybe "") (zipWith f ns rs)
where (unexpected, ms') = span ((== 0) . fromEnum) ms
(expected, messages) = span ((== 1) . fromEnum) ms'
f prefix m = (prefix ++) <$> m
ns = ["\nunexpected ","\nexpecting ","\n"]
rs = (renderMsgs orList <$> [unexpected, expected]) ++
[renderMsgs (intercalate "\n") messages]
renderMsgs
:: ([String] -> String)
-> [Message]
-> Maybe String
renderMsgs _ [] = Nothing
renderMsgs f ms = Just . f $ messageString <$> ms
orList :: [String] -> String
orList [] = ""
orList [x] = x
orList [x,y] = x ++ " or " ++ y
orList xs = intercalate ", " (init xs) ++ ", or " ++ last xs