1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.Parsec.Error
-- Copyright : (c) Daan Leijen 1999-2001
-- License : BSD-style (see the file libraries/parsec/LICENSE)
--
-- Maintainer : daan@cs.uu.nl
-- Stability : provisional
-- Portability : portable
--
-- Parse errors
--
-----------------------------------------------------------------------------
module Text.ParserCombinators.Parsec.Error
( Message(SysUnExpect,UnExpect,Expect,Message)
, messageString, messageCompare, messageEq
, ParseError, errorPos, errorMessages, errorIsUnknown
, showErrorMessages
, newErrorMessage, newErrorUnknown
, addErrorMessage, setErrorPos, setErrorMessage
, mergeError
)
where
import Prelude
import Data.List (nub,sortBy)
import Text.ParserCombinators.Parsec.Pos
-----------------------------------------------------------
-- Messages
-----------------------------------------------------------
data Message = SysUnExpect !String --library generated unexpect
| UnExpect !String --unexpected something
| Expect !String --expecting something
| Message !String --raw message
messageToEnum msg
= case msg of SysUnExpect _ -> 0
UnExpect _ -> 1
Expect _ -> 2
Message _ -> 3
messageCompare :: Message -> Message -> Ordering
messageCompare msg1 msg2
= compare (messageToEnum msg1) (messageToEnum msg2)
messageString :: Message -> String
messageString msg
= case msg of SysUnExpect s -> s
UnExpect s -> s
Expect s -> s
Message s -> s
messageEq :: Message -> Message -> Bool
messageEq msg1 msg2
= (messageCompare msg1 msg2 == EQ)
-----------------------------------------------------------
-- Parse Errors
-----------------------------------------------------------
data ParseError = ParseError !SourcePos [Message]
errorPos :: ParseError -> SourcePos
errorPos (ParseError pos msgs)
= pos
errorMessages :: ParseError -> [Message]
errorMessages (ParseError pos msgs)
= sortBy messageCompare msgs
errorIsUnknown :: ParseError -> Bool
errorIsUnknown (ParseError pos msgs)
= null msgs
-----------------------------------------------------------
-- Create parse errors
-----------------------------------------------------------
newErrorUnknown :: SourcePos -> ParseError
newErrorUnknown pos
= ParseError pos []
newErrorMessage :: Message -> SourcePos -> ParseError
newErrorMessage msg pos
= ParseError pos [msg]
addErrorMessage :: Message -> ParseError -> ParseError
addErrorMessage msg (ParseError pos msgs)
= ParseError pos (msg:msgs)
setErrorPos :: SourcePos -> ParseError -> ParseError
setErrorPos pos (ParseError _ msgs)
= ParseError pos msgs
setErrorMessage :: Message -> ParseError -> ParseError
setErrorMessage msg (ParseError pos msgs)
= ParseError pos (msg:filter (not . messageEq msg) msgs)
mergeError :: ParseError -> ParseError -> ParseError
mergeError (ParseError pos msgs1) (ParseError _ msgs2)
= ParseError pos (msgs1 ++ msgs2)
-----------------------------------------------------------
-- Show Parse Errors
-----------------------------------------------------------
instance Show ParseError where
show err
= show (errorPos err) ++ ":" ++
showErrorMessages "or" "unknown parse error"
"expecting" "unexpected" "end of input"
(errorMessages err)
-- | Language independent show function
showErrorMessages ::
String -> String -> String -> String -> String -> [Message] -> String
showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
| null msgs = msgUnknown
| otherwise = concat $ map ("\n"++) $ clean $
[showSysUnExpect,showUnExpect,showExpect,showMessages]
where
(sysUnExpect,msgs1) = span (messageEq (SysUnExpect "")) msgs
(unExpect,msgs2) = span (messageEq (UnExpect "")) msgs1
(expect,messages) = span (messageEq (Expect "")) msgs2
showExpect = showMany msgExpecting expect
showUnExpect = showMany msgUnExpected unExpect
showSysUnExpect | not (null unExpect) ||
null sysUnExpect = ""
| null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput
| otherwise = msgUnExpected ++ " " ++ firstMsg
where
firstMsg = messageString (head sysUnExpect)
showMessages = showMany "" messages
--helpers
showMany pre msgs = case (clean (map messageString msgs)) of
[] -> ""
ms | null pre -> commasOr ms
| otherwise -> pre ++ " " ++ commasOr ms
commasOr [] = ""
commasOr [m] = m
commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
commaSep = seperate ", " . clean
semiSep = seperate "; " . clean
seperate sep [] = ""
seperate sep [m] = m
seperate sep (m:ms) = m ++ sep ++ seperate sep ms
clean = nub . filter (not.null)
|
