{- |
Module      :  Text.ParserCombinators.Parsec.Error
Copyright   :  (c) Daan Leijen 1999-2001
License     :  BSD-style (see the file LICENSE)

Maintainer  :  Christian Maeder <chr.maeder@web.de>
Stability   :  provisional
Portability :  portable

Parse errors
-}

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


import Data.List (nub, sortBy)

import Text.ParserCombinators.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 Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq

messageToEnum :: Message -> Int
messageToEnum :: Message -> Int
messageToEnum Message
msg = case Message
msg of
  SysUnExpect String
_ -> Int
0
  UnExpect String
_ -> Int
1
  Expect String
_ -> Int
2
  Message String
_ -> Int
3

messageCompare :: Message -> Message -> Ordering
messageCompare :: Message -> Message -> Ordering
messageCompare Message
msg1 Message
msg2
    = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Message -> Int
messageToEnum Message
msg1) (Message -> Int
messageToEnum Message
msg2)

-- | Extract the message string from an error message
messageString :: Message -> String
messageString :: Message -> String
messageString Message
msg = case Message
msg of
  SysUnExpect String
s -> String
s
  UnExpect String
s -> String
s
  Expect String
s -> String
s
  Message String
s -> String
s

messageEq :: Message -> Message -> Bool
messageEq :: Message -> Message -> Bool
messageEq Message
msg1 Message
msg2
    = Message -> Message -> Ordering
messageCompare Message
msg1 Message
msg2 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ


{- | 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' class. -}
data ParseError = ParseError !SourcePos [Message] deriving ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq

-- | 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 -> Ordering) -> [Message] -> [Message]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Message -> Message -> Ordering
messageCompare [Message]
msgs

errorIsUnknown :: ParseError -> Bool
errorIsUnknown :: ParseError -> Bool
errorIsUnknown (ParseError SourcePos
_pos [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 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
msg Message -> [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 (Bool -> Bool
not (Bool -> Bool) -> (Message -> Bool) -> Message -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Message -> Bool
messageEq Message
msg) [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 (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
        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

{- ---------------------------------------------------------
Show Parse Errors
--------------------------------------------------------- -}
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)

-- | Language independent show function
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs = String
msgUnknown
    | Bool
otherwise = ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
clean
                 [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 (Message -> Message -> Bool
messageEq (String -> Message
SysUnExpect String
"")) [Message]
msgs
      ([Message]
unExpect, [Message]
msgs2) = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Message -> Message -> Bool
messageEq (String -> Message
UnExpect String
"")) [Message]
msgs1
      ([Message]
expect, [Message]
messages) = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Message -> Message -> Bool
messageEq (String -> Message
Expect String
"")) [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 (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 = String
""
        | String -> 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. [a] -> a
head [Message]
sysUnExpect)

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

      -- helpers
      showMany :: String -> [Message] -> String
showMany String
pre [Message]
es = case [String] -> [String]
clean ((Message -> String) -> [Message] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Message -> String
messageString [Message]
es) of
        [] -> String
""
        [String]
ms | String -> 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]
ms = case [String]
ms of
        [] -> String
""
        [String
m] -> String
m
        [String]
_ -> [String] -> String
commaSep ([String] -> [String]
forall a. [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. [a] -> a
last [String]
ms

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

      seperate :: String -> [String] -> String
seperate String
sep [String]
ms = case [String]
ms of
        [] -> String
""
        [String
m] -> String
m
        String
m : [String]
rs -> String
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
seperate String
sep [String]
rs

      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 (t :: * -> *) a. Foldable t => t a -> Bool
null)