1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE Safe #-}
3
4-----------------------------------------------------------------------------
5-- |
6-- Module      :  Text.Parsec.Error
7-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
8-- License     :  BSD-style (see the LICENSE file)
9--
10-- Maintainer  :  derek.a.elkins@gmail.com
11-- Stability   :  provisional
12-- Portability :  portable
13--
14-- Parse errors
15--
16-----------------------------------------------------------------------------
17
18module Text.Parsec.Error
19    ( Message ( SysUnExpect, UnExpect, Expect, Message )
20    , messageString
21    , ParseError, errorPos, errorMessages, errorIsUnknown
22    , showErrorMessages
23    , newErrorMessage, newErrorUnknown
24    , addErrorMessage, setErrorPos, setErrorMessage
25    , mergeError
26    ) where
27
28import Data.List ( nub, sort )
29import Data.Typeable ( Typeable )
30
31import Text.Parsec.Pos
32
33-- | This abstract data type represents parse error messages. There are
34-- four kinds of messages:
35--
36-- >  data Message = SysUnExpect String
37-- >               | UnExpect String
38-- >               | Expect String
39-- >               | Message String
40--
41-- The fine distinction between different kinds of parse errors allows
42-- the system to generate quite good error messages for the user. It
43-- also allows error messages that are formatted in different
44-- languages. Each kind of message is generated by different combinators:
45--
46--     * A 'SysUnExpect' message is automatically generated by the
47--       'Text.Parsec.Combinator.satisfy' combinator. The argument is the
48--       unexpected input.
49--
50--     * A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected'
51--       combinator. The argument describes the
52--       unexpected item.
53--
54--     * A 'Expect' message is generated by the 'Text.Parsec.Prim.<?>'
55--       combinator. The argument describes the expected item.
56--
57--     * A 'Message' message is generated by the 'fail'
58--       combinator. The argument is some general parser message.
59
60data Message = SysUnExpect !String -- @ library generated unexpect
61             | UnExpect    !String -- @ unexpected something
62             | Expect      !String -- @ expecting something
63             | Message     !String -- @ raw message
64    deriving ( Typeable )
65
66instance Enum Message where
67    fromEnum (SysUnExpect _) = 0
68    fromEnum (UnExpect    _) = 1
69    fromEnum (Expect      _) = 2
70    fromEnum (Message     _) = 3
71    toEnum _ = error "toEnum is undefined for Message"
72
73-- < Return 'True' only when 'compare' would return 'EQ'.
74
75instance Eq Message where
76
77    m1 == m2 = fromEnum m1 == fromEnum m2
78
79-- < Compares two error messages without looking at their content. Only
80-- the constructors are compared where:
81--
82-- > 'SysUnExpect' < 'UnExpect' < 'Expect' < 'Message'
83
84instance Ord Message where
85    compare msg1 msg2 = compare (fromEnum msg1) (fromEnum msg2)
86
87-- | Extract the message string from an error message
88
89messageString :: Message -> String
90messageString (SysUnExpect s) = s
91messageString (UnExpect    s) = s
92messageString (Expect      s) = s
93messageString (Message     s) = s
94
95-- | The abstract data type @ParseError@ represents parse errors. It
96-- provides the source position ('SourcePos') of the error
97-- and a list of error messages ('Message'). A @ParseError@
98-- can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an
99-- instance of the 'Show' and 'Eq' classes.
100
101data ParseError = ParseError !SourcePos [Message]
102    deriving ( Typeable )
103
104-- | Extracts the source position from the parse error
105
106errorPos :: ParseError -> SourcePos
107errorPos (ParseError pos _msgs)
108    = pos
109
110-- | Extracts the list of error messages from the parse error
111
112errorMessages :: ParseError -> [Message]
113errorMessages (ParseError _pos msgs)
114    = sort msgs
115
116errorIsUnknown :: ParseError -> Bool
117errorIsUnknown (ParseError _pos msgs)
118    = null msgs
119
120-- < Create parse errors
121
122newErrorUnknown :: SourcePos -> ParseError
123newErrorUnknown pos
124    = ParseError pos []
125
126newErrorMessage :: Message -> SourcePos -> ParseError
127newErrorMessage msg pos
128    = ParseError pos [msg]
129
130addErrorMessage :: Message -> ParseError -> ParseError
131addErrorMessage msg (ParseError pos msgs)
132    = ParseError pos (msg:msgs)
133
134setErrorPos :: SourcePos -> ParseError -> ParseError
135setErrorPos pos (ParseError _ msgs)
136    = ParseError pos msgs
137
138setErrorMessage :: Message -> ParseError -> ParseError
139setErrorMessage msg (ParseError pos msgs)
140    = ParseError pos (msg : filter (msg /=) msgs)
141
142mergeError :: ParseError -> ParseError -> ParseError
143mergeError e1@(ParseError pos1 msgs1) e2@(ParseError pos2 msgs2)
144    -- prefer meaningful errors
145    | null msgs2 && not (null msgs1) = e1
146    | null msgs1 && not (null msgs2) = e2
147    | otherwise
148    = case pos1 `compare` pos2 of
149        -- select the longest match
150        EQ -> ParseError pos1 (msgs1 ++ msgs2)
151        GT -> e1
152        LT -> e2
153
154instance Show ParseError where
155    show err
156        = show (errorPos err) ++ ":" ++
157          showErrorMessages "or" "unknown parse error"
158                            "expecting" "unexpected" "end of input"
159                           (errorMessages err)
160
161instance Eq ParseError where
162    l == r
163        = errorPos l == errorPos r && messageStrs l == messageStrs r
164        where
165          messageStrs = map messageString . errorMessages
166
167-- Language independent show function
168
169--  TODO
170-- < The standard function for showing error messages. Formats a list of
171--    error messages in English. This function is used in the |Show|
172--    instance of |ParseError <#ParseError>|. The resulting string will be
173--    formatted like:
174--
175--    |unexpected /{The first UnExpect or a SysUnExpect message}/;
176--    expecting /{comma separated list of Expect messages}/;
177--    /{comma separated list of Message messages}/
178
179showErrorMessages ::
180    String -> String -> String -> String -> String -> [Message] -> String
181showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
182    | null msgs = msgUnknown
183    | otherwise = concat $ map ("\n"++) $ clean $
184                 [showSysUnExpect,showUnExpect,showExpect,showMessages]
185    where
186      (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
187      (unExpect,msgs2)    = span ((UnExpect    "") ==) msgs1
188      (expect,messages)   = span ((Expect      "") ==) msgs2
189
190      showExpect      = showMany msgExpecting expect
191      showUnExpect    = showMany msgUnExpected unExpect
192      showSysUnExpect | not (null unExpect) ||
193                        null sysUnExpect = ""
194                      | null firstMsg    = msgUnExpected ++ " " ++ msgEndOfInput
195                      | otherwise        = msgUnExpected ++ " " ++ firstMsg
196          where
197              firstMsg  = messageString (head sysUnExpect)
198
199      showMessages      = showMany "" messages
200
201      -- helpers
202      showMany pre msgs3 = case clean (map messageString msgs3) of
203                            [] -> ""
204                            ms | null pre  -> commasOr ms
205                               | otherwise -> pre ++ " " ++ commasOr ms
206
207      commasOr []       = ""
208      commasOr [m]      = m
209      commasOr ms       = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
210
211      commaSep          = separate ", " . clean
212
213      separate   _ []     = ""
214      separate   _ [m]    = m
215      separate sep (m:ms) = m ++ sep ++ separate sep ms
216
217      clean             = nub . filter (not . null)
218