{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Parsec.Error
-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
-- License     :  BSD-style (see the LICENSE file)
--
-- Maintainer  :  derek.a.elkins@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Parse errors
--
-----------------------------------------------------------------------------

module Text.Parsec.Error
    ( Message ( SysUnExpect, UnExpect, Expect, Message )
    , messageString
    , ParseError, errorPos, errorMessages, errorIsUnknown
    , showErrorMessages
    , newErrorMessage, newErrorUnknown
    , addErrorMessage, setErrorPos, setErrorMessage
    , mergeError
    ) where

import Data.List ( nub, sort )
import Data.Typeable ( Typeable )

import Text.Parsec.Pos

-- | This abstract data type represents parse error messages. There are
-- four kinds of messages:
--
-- >  data Message = SysUnExpect String
-- >               | UnExpect String
-- >               | Expect String
-- >               | Message String
--
-- The fine distinction between different kinds of parse errors allows
-- the system to generate quite good error messages for the user. It
-- also allows error messages that are formatted in different
-- languages. Each kind of message is generated by different combinators:
--
--     * A 'SysUnExpect' message is automatically generated by the
--       'Text.Parsec.Combinator.satisfy' combinator. The argument is the
--       unexpected input.
--
--     * A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected'
--       combinator. The argument describes the
--       unexpected item.
--
--     * A 'Expect' message is generated by the 'Text.Parsec.Prim.<?>'
--       combinator. The argument describes the expected item.
--
--     * A 'Message' message is generated by the 'fail'
--       combinator. The argument is some general parser message.

data Message = SysUnExpect !String -- @ library generated unexpect
             | UnExpect    !String -- @ unexpected something
             | Expect      !String -- @ expecting something
             | Message     !String -- @ raw message
    deriving ( Typeable )

instance Enum Message where
    fromEnum :: Message -> Int
fromEnum (SysUnExpect _) = 0
    fromEnum (UnExpect    _) = 1
    fromEnum (Expect      _) = 2
    fromEnum (Message     _) = 3
    toEnum :: Int -> Message
toEnum _ = [Char] -> Message
forall a. HasCallStack => [Char] -> a
error "toEnum is undefined for Message"

-- < Return 'True' only when 'compare' would return 'EQ'.

instance Eq Message where

    m1 :: Message
m1 == :: Message -> Message -> Bool
== m2 :: Message
m2 = Message -> Int
forall a. Enum a => a -> Int
fromEnum Message
m1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Message -> Int
forall a. Enum a => a -> Int
fromEnum Message
m2

-- < Compares two error messages without looking at their content. Only
-- the constructors are compared where:
--
-- > 'SysUnExpect' < 'UnExpect' < 'Expect' < 'Message'

instance Ord Message where
    compare :: Message -> Message -> Ordering
compare msg1 :: Message
msg1 msg2 :: Message
msg2 = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Message -> Int
forall a. Enum a => a -> Int
fromEnum Message
msg1) (Message -> Int
forall a. Enum a => a -> Int
fromEnum Message
msg2)

-- | Extract the message string from an error message

messageString :: Message -> String
messageString :: Message -> [Char]
messageString (SysUnExpect s :: [Char]
s) = [Char]
s
messageString (UnExpect    s :: [Char]
s) = [Char]
s
messageString (Expect      s :: [Char]
s) = [Char]
s
messageString (Message     s :: [Char]
s) = [Char]
s

-- | The abstract data type @ParseError@ represents parse errors. It
-- provides the source position ('SourcePos') of the error
-- and a list of error messages ('Message'). A @ParseError@
-- can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an
-- instance of the 'Show' and 'Eq' classes.

data ParseError = ParseError !SourcePos [Message]
    deriving ( Typeable )

-- | Extracts the source position from the parse error

errorPos :: ParseError -> SourcePos
errorPos :: ParseError -> SourcePos
errorPos (ParseError pos :: SourcePos
pos _msgs :: [Message]
_msgs)
    = SourcePos
pos

-- | Extracts the list of error messages from the parse error

errorMessages :: ParseError -> [Message]
errorMessages :: ParseError -> [Message]
errorMessages (ParseError _pos :: SourcePos
_pos msgs :: [Message]
msgs)
    = [Message] -> [Message]
forall a. Ord a => [a] -> [a]
sort [Message]
msgs

errorIsUnknown :: ParseError -> Bool
errorIsUnknown :: ParseError -> Bool
errorIsUnknown (ParseError _pos :: SourcePos
_pos msgs :: [Message]
msgs)
    = [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs

-- < Create parse errors

newErrorUnknown :: SourcePos -> ParseError
newErrorUnknown :: SourcePos -> ParseError
newErrorUnknown pos :: SourcePos
pos
    = SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos []

newErrorMessage :: Message -> SourcePos -> ParseError
newErrorMessage :: Message -> SourcePos -> ParseError
newErrorMessage msg :: Message
msg pos :: SourcePos
pos
    = SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos [Message
msg]

addErrorMessage :: Message -> ParseError -> ParseError
addErrorMessage :: Message -> ParseError -> ParseError
addErrorMessage msg :: Message
msg (ParseError pos :: SourcePos
pos msgs :: [Message]
msgs)
    = SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos (Message
msgMessage -> [Message] -> [Message]
forall a. a -> [a] -> [a]
:[Message]
msgs)

setErrorPos :: SourcePos -> ParseError -> ParseError
setErrorPos :: SourcePos -> ParseError -> ParseError
setErrorPos pos :: SourcePos
pos (ParseError _ msgs :: [Message]
msgs)
    = SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos [Message]
msgs

setErrorMessage :: Message -> ParseError -> ParseError
setErrorMessage :: Message -> ParseError -> ParseError
setErrorMessage msg :: Message
msg (ParseError pos :: SourcePos
pos msgs :: [Message]
msgs)
    = SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos (Message
msg Message -> [Message] -> [Message]
forall a. a -> [a] -> [a]
: (Message -> Bool) -> [Message] -> [Message]
forall a. (a -> Bool) -> [a] -> [a]
filter (Message
msg Message -> Message -> Bool
forall a. Eq a => a -> a -> Bool
/=) [Message]
msgs)

mergeError :: ParseError -> ParseError -> ParseError
mergeError :: ParseError -> ParseError -> ParseError
mergeError e1 :: ParseError
e1@(ParseError pos1 :: SourcePos
pos1 msgs1 :: [Message]
msgs1) e2 :: ParseError
e2@(ParseError pos2 :: SourcePos
pos2 msgs2 :: [Message]
msgs2)
    -- prefer meaningful errors
    | [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs1) = ParseError
e1
    | [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs2) = ParseError
e2
    | Bool
otherwise
    = case SourcePos
pos1 SourcePos -> SourcePos -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SourcePos
pos2 of
        -- select the longest match
        EQ -> SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos1 ([Message]
msgs1 [Message] -> [Message] -> [Message]
forall a. [a] -> [a] -> [a]
++ [Message]
msgs2)
        GT -> ParseError
e1
        LT -> ParseError
e2

instance Show ParseError where
    show :: ParseError -> [Char]
show err :: ParseError
err
        = SourcePos -> [Char]
forall a. Show a => a -> [Char]
show (ParseError -> SourcePos
errorPos ParseError
err) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
          [Char]
-> [Char] -> [Char] -> [Char] -> [Char] -> [Message] -> [Char]
showErrorMessages "or" "unknown parse error"
                            "expecting" "unexpected" "end of input"
                           (ParseError -> [Message]
errorMessages ParseError
err)

instance Eq ParseError where
    l :: ParseError
l == :: ParseError -> ParseError -> Bool
== r :: ParseError
r
        = ParseError -> SourcePos
errorPos ParseError
l SourcePos -> SourcePos -> Bool
forall a. Eq a => a -> a -> Bool
== ParseError -> SourcePos
errorPos ParseError
r Bool -> Bool -> Bool
&& ParseError -> [[Char]]
messageStrs ParseError
l [[Char]] -> [[Char]] -> Bool
forall a. Eq a => a -> a -> Bool
== ParseError -> [[Char]]
messageStrs ParseError
r
        where
          messageStrs :: ParseError -> [[Char]]
messageStrs = (Message -> [Char]) -> [Message] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Message -> [Char]
messageString ([Message] -> [[Char]])
-> (ParseError -> [Message]) -> ParseError -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Message]
errorMessages

-- Language independent show function

--  TODO
-- < The standard function for showing error messages. Formats a list of
--    error messages in English. This function is used in the |Show|
--    instance of |ParseError <#ParseError>|. The resulting string will be
--    formatted like:
--
--    |unexpected /{The first UnExpect or a SysUnExpect message}/;
--    expecting /{comma separated list of Expect messages}/;
--    /{comma separated list of Message messages}/

showErrorMessages ::
    String -> String -> String -> String -> String -> [Message] -> String
showErrorMessages :: [Char]
-> [Char] -> [Char] -> [Char] -> [Char] -> [Message] -> [Char]
showErrorMessages msgOr :: [Char]
msgOr msgUnknown :: [Char]
msgUnknown msgExpecting :: [Char]
msgExpecting msgUnExpected :: [Char]
msgUnExpected msgEndOfInput :: [Char]
msgEndOfInput msgs :: [Message]
msgs
    | [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs = [Char]
msgUnknown
    | Bool
otherwise = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ("\n"[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
clean ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
                 [[Char]
showSysUnExpect,[Char]
showUnExpect,[Char]
showExpect,[Char]
showMessages]
    where
      (sysUnExpect :: [Message]
sysUnExpect,msgs1 :: [Message]
msgs1) = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
SysUnExpect "") Message -> Message -> Bool
forall a. Eq a => a -> a -> Bool
==) [Message]
msgs
      (unExpect :: [Message]
unExpect,msgs2 :: [Message]
msgs2)    = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
UnExpect    "") Message -> Message -> Bool
forall a. Eq a => a -> a -> Bool
==) [Message]
msgs1
      (expect :: [Message]
expect,messages :: [Message]
messages)   = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
Expect      "") Message -> Message -> Bool
forall a. Eq a => a -> a -> Bool
==) [Message]
msgs2

      showExpect :: [Char]
showExpect      = [Char] -> [Message] -> [Char]
showMany [Char]
msgExpecting [Message]
expect
      showUnExpect :: [Char]
showUnExpect    = [Char] -> [Message] -> [Char]
showMany [Char]
msgUnExpected [Message]
unExpect
      showSysUnExpect :: [Char]
showSysUnExpect | Bool -> Bool
not ([Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
unExpect) Bool -> Bool -> Bool
||
                        [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
sysUnExpect = ""
                      | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
firstMsg    = [Char]
msgUnExpected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msgEndOfInput
                      | Bool
otherwise        = [Char]
msgUnExpected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
firstMsg
          where
              firstMsg :: [Char]
firstMsg  = Message -> [Char]
messageString ([Message] -> Message
forall a. [a] -> a
head [Message]
sysUnExpect)

      showMessages :: [Char]
showMessages      = [Char] -> [Message] -> [Char]
showMany "" [Message]
messages

      -- helpers
      showMany :: [Char] -> [Message] -> [Char]
showMany pre :: [Char]
pre msgs3 :: [Message]
msgs3 = case [[Char]] -> [[Char]]
clean ((Message -> [Char]) -> [Message] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Message -> [Char]
messageString [Message]
msgs3) of
                            [] -> ""
                            ms :: [[Char]]
ms | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
pre  -> [[Char]] -> [Char]
commasOr [[Char]]
ms
                               | Bool
otherwise -> [Char]
pre [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
commasOr [[Char]]
ms

      commasOr :: [[Char]] -> [Char]
commasOr []       = ""
      commasOr [m :: [Char]
m]      = [Char]
m
      commasOr ms :: [[Char]]
ms       = [[Char]] -> [Char]
commaSep ([[Char]] -> [[Char]]
forall a. [a] -> [a]
init [[Char]]
ms) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msgOr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. [a] -> a
last [[Char]]
ms

      commaSep :: [[Char]] -> [Char]
commaSep          = [Char] -> [[Char]] -> [Char]
separate ", " ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
clean

      separate :: [Char] -> [[Char]] -> [Char]
separate   _ []     = ""
      separate   _ [m :: [Char]
m]    = [Char]
m
      separate sep :: [Char]
sep (m :: [Char]
m:ms :: [[Char]]
ms) = [Char]
m [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
sep [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
separate [Char]
sep [[Char]]
ms

      clean :: [[Char]] -> [[Char]]
clean             = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)