{-# 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 String
_) = Int
0
    fromEnum (UnExpect    String
_) = Int
1
    fromEnum (Expect      String
_) = Int
2
    fromEnum (Message     String
_) = Int
3
    toEnum :: Int -> Message
toEnum Int
_ = String -> Message
forall a. HasCallStack => String -> a
error String
"toEnum is undefined for Message"

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

instance Eq Message where

    Message
m1 == :: Message -> Message -> Bool
== 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 Message
msg1 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 -> String
messageString (SysUnExpect String
s) = String
s
messageString (UnExpect    String
s) = String
s
messageString (Expect      String
s) = String
s
messageString (Message     String
s) = String
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 SourcePos
pos [Message]
_msgs)
    = SourcePos
pos

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

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

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

-- < Create parse errors

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

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

addErrorMessage :: Message -> ParseError -> ParseError
addErrorMessage :: Message -> ParseError -> ParseError
addErrorMessage Message
msg (ParseError SourcePos
pos [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 SourcePos
pos (ParseError SourcePos
_ [Message]
msgs)
    = SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos [Message]
msgs

setErrorMessage :: Message -> ParseError -> ParseError
setErrorMessage :: Message -> ParseError -> ParseError
setErrorMessage Message
msg (ParseError SourcePos
pos [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 SourcePos
pos1 [Message]
msgs1) e2 :: ParseError
e2@(ParseError SourcePos
pos2 [Message]
msgs2)
    -- prefer meaningful errors
    | [Message] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Message] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs1) = ParseError
e1
    | [Message] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Message] -> Bool
forall a. [a] -> 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
        Ordering
EQ -> SourcePos -> [Message] -> ParseError
ParseError SourcePos
pos1 ([Message]
msgs1 [Message] -> [Message] -> [Message]
forall a. [a] -> [a] -> [a]
++ [Message]
msgs2)
        Ordering
GT -> ParseError
e1
        Ordering
LT -> ParseError
e2

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

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

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

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

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

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

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

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

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