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
|
# -*- tcl -*-
# Copyright (c) 2014 Andreas Kupries <andreas_kupries@sourceforge.net>
# Utility commands for parser syntax errors.
# # ## ### ##### ######## ############# #####################
## Requirements
package require Tcl 8.5 ; # Required runtime.
package require char
# # ## ### ##### ######## ############# #####################
##
namespace eval ::pt::util {
namespace export error2readable error2position error2text
namespace ensemble create
namespace import ::char::quote
}
# # ## ### ##### ######## #############
## Public API
proc ::pt::util::error2readable {error text} {
lassign $error _ location msgs
lassign [Position $location $text] l c
lappend map \n \\n
lappend map \r \\r
lappend map \t \\t
# Get 10 chars before and after the failure point. Depending on
# the relative position of input beginning and end we may get less
# back of either. Special characters in the input (line endings,
# tabs) are quoted to keep this on a single line.
set prefix [string map $map [string range $text ${location}-10 $location]]
set suffix [string map $map [string range $text ${location}+1 ${location}+10]]
# Construct a line pointing to the failure position. By using the
# transformed prefix as our source (length) no complex
# calculations are required. It is implicit in the prefix/suffix
# separation above.
set n [string length $prefix]
incr n -1
set point [string repeat - $n]
append point ^
# Print our results.
lappend lines "Parse error at position $location (Line $l, column $c)."
lappend lines "... ${prefix}${suffix} ..."
lappend lines " $point"
lappend lines "Expected one of"
lappend lines "* [join [Readables $msgs] "\n* "]"
lappend lines ""
return [join $lines \n]
}
proc ::pt::util::error2position {error text} {
lassign $error _ location msgs
return [Position $location $text]
}
proc ::pt::util::error2text {error} {
lassign $error _ location msgs
return [Readables $msgs]
}
# # ## ### ##### ######## #############
## Internals
proc ::pt::util::Position {location text} {
incr location -1
# Computing the line/col of a position is quite easy. Split the
# part before the location into lines (at eol), count them, and
# look at the length of the last line in that.
set prefix [string range $text 0 $location]
set lines [split $prefix \n]
set line [llength $lines]
set col [string length [lindex $lines end]]
return [list $line $col]
}
proc ::pt::util::Readables {msgs} {
set cl {}
set r {}
foreach pe $msgs {
switch -exact -- [lindex $pe 0] {
t {
# Fuse to multiple 't'-tags into a single 'cl'-tag.
lappend cl [lindex $pe 1]
}
cl {
# Fuse multiple 'cl'-tags into one.
foreach c [split [lindex $pe 1]] { lappend cl $c }
}
default {
lappend r [Readable $pe]
}
}
}
if {[set n [llength $cl]]} {
if {$n > 1} {
lappend r [Readable [list cl [join [lsort -dict $cl] {}]]]
} else {
lappend r [Readable [list t [lindex $cl 0]]]
}
}
return [lsort -dict $r]
}
proc ::pt::util::Readable {pe} {
set details [lassign $pe tag]
switch -exact -- $tag {
t {
set details [quote string {*}$details]
set m "The character '$details'"
}
n { set m "The symbol $details" }
.. {
set details [quote string {*}$details]
set m "A character in range '[join $details '-']'"
}
str {
set details [join [quote string {*}[split $details {}]] {}]
set m "A string \"$details\""
}
cl {
set details [join [quote string {*}[split $details {}]] {}]
set m "A character in set \{$details\}"
}
alpha { set m "A unicode alphabetical character" }
alnum { set m "A unicode alphanumerical character" }
ascii { set m "An ascii character" }
digit { set m "A unicode digit character" }
graph { set m "A unicode printing character, but not space" }
lower { set m "A unicode lower-case alphabetical character" }
print { set m "A unicode printing character, including space" }
control { set m "A unicode control character" }
punct { set m "A unicode punctuation character" }
space { set m "A unicode space character" }
upper { set m "A unicode upper-case alphabetical character" }
wordchar { set m "A unicode word character (alphanumerics + connectors)" }
xdigit { set m "A hexadecimal digit" }
ddigit { set m "A decimal digit" }
dot { set m "Any character" }
default { set m [string totitle $tag] }
}
return $m
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide pt::util 1.1
return
|
