-
-
Notifications
You must be signed in to change notification settings - Fork 373
/
Str.pm
224 lines (203 loc) · 7.33 KB
/
Str.pm
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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
our $?TABSTOP = 8;
augment class Str does Stringy {
multi method Bool { ?(pir::istrue__IP(self)); }
method Str() { self }
my @KNOWN_ENCODINGS = <utf-8 iso-8859-1 ascii>;
# XXX: We have no $?ENC or $?NF compile-time constants yet.
multi method encode($encoding is copy = 'utf-8', $nf = '') {
if $encoding eq 'latin-1' {
$encoding = 'iso-8859-1';
}
die "Unknown encoding $encoding"
unless $encoding.lc eq any @KNOWN_ENCODINGS;
$encoding .= lc;
my @bytes = Q:PIR {
.local int byte
.local pmc bytebuffer, it, result
$P0 = find_lex 'self'
$S0 = $P0
$P1 = find_lex '$encoding'
$S1 = $P1
if $S1 == 'ascii' goto transcode_ascii
if $S1 == 'iso-8859-1' goto transcode_iso_8859_1
# NOTE: There's an assumption here, that all strings coming in
# from the rest of Rakudo are always in UTF-8 form. Don't
# know if this assumption always holds; to be on the safe
# side, we might transcode even to UTF-8.
goto finished_transcoding
transcode_ascii:
$I0 = find_encoding 'ascii'
$S0 = trans_encoding $S0, $I0
goto finished_transcoding
transcode_iso_8859_1:
$I0 = find_encoding 'iso-8859-1'
$S0 = trans_encoding $S0, $I0
finished_transcoding:
bytebuffer = new ['ByteBuffer']
bytebuffer = $S0
result = new ['Parcel']
it = iter bytebuffer
bytes_loop:
unless it goto done
byte = shift it
push result, byte
goto bytes_loop
done:
%r = result
};
return Buf.new(@bytes);
}
# Zero indent does nothing
multi method indent($steps as Int where { $_ == 0 }) {
self;
}
# Positive indent does indent
multi method indent($steps as Int where { $_ > 0 }) {
# We want to keep trailing \n so we have to .comb explicitly instead of .lines
return self.comb(/:r ^^ \N* \n?/).map({
given $_ {
# Use the existing space character if they're all the same
# (but tabs are done slightly differently)
when /^(\t+) ([ \S .* | $ ])/ {
$0 ~ "\t" x ($steps div $?TABSTOP) ~
' ' x ($steps mod $?TABSTOP) ~ $1
}
when /^(\h) $0* [ \S | $ ]/ {
$0 x $steps ~ $_
}
# Otherwise we just insert spaces after the existing leading space
default {
($_ ~~ /^(\h*) (.*)$/).join(' ' x $steps)
}
}
}).join;
}
# Negative values and Whatever-* do outdent
multi method indent($steps) {
# Loop through all lines to get as much info out of them as possible
my @lines = self.comb(/:r ^^ \N* \n?/).map({
# Split the line into indent and content
my ($indent, $rest) = @($_ ~~ /^(\h*) (.*)$/);
# Split the indent into characters and annotate them
# with their visual size
my $indent-size = 0;
my @indent-chars = $indent.comb.map(-> $char {
my $width = $char eq "\t"
?? $?TABSTOP - ($indent-size mod $?TABSTOP)
!! 1;
$indent-size += $width;
$char => $width;
});
{ :$indent-size, :@indent-chars, :$rest };
});
# Figure out the amount * should outdent by, we also use this for warnings
my $common-prefix = [min] @lines.map({ $_<indent-size> });
# Set the actual outdent amount here
my Int $outdent = $steps ~~ Whatever ?? $common-prefix
!! -$steps;
warn sprintf('Asked to remove %d spaces, ' ~
'but the shortest indent is %d spaces',
$outdent, $common-prefix) if $outdent > $common-prefix;
# Work backwards from the right end of the indent whitespace, removing
# array elements up to # (or over, in the case of tab-explosion)
# the specified outdent amount.
@lines.map({
my $pos = 0;
while $_<indent-chars> and $pos < $outdent {
$pos += $_<indent-chars>.pop.value;
}
$_<indent-chars>».key.join ~ ' ' x ($pos - $outdent) ~ $_<rest>;
}).join;
}
our sub str2num-int($src) {
Q:PIR {
.local pmc src
.local string src_s
src = find_lex '$src'
src_s = src
.local int pos, eos
.local num result
pos = 0
eos = length src_s
result = 0
str_loop:
unless pos < eos goto str_done
.local string char
char = substr src_s, pos, 1
if char == '_' goto str_next
.local int digitval
digitval = index "0123456789", char
if digitval < 0 goto err_base
if digitval >= 10 goto err_base
result *= 10
result += digitval
str_next:
inc pos
goto str_loop
err_base:
src.'panic'('Invalid radix conversion of "', char, '"')
str_done:
%r = box result
};
}
our sub str2num-base($src) {
Q:PIR {
.local pmc src
.local string src_s
src = find_lex '$src'
src_s = src
.local int pos, eos
.local num result
pos = 0
eos = length src_s
result = 1
str_loop:
unless pos < eos goto str_done
.local string char
char = substr src_s, pos, 1
if char == '_' goto str_next
result *= 10
str_next:
inc pos
goto str_loop
err_base:
src.'panic'('Invalid radix conversion of "', char, '"')
str_done:
%r = box result
};
}
sub chop-trailing-zeros($i) {
Q:PIR {
.local int idx
$P0 = find_lex '$i'
$S0 = $P0
idx = length $S0
repl_loop:
if idx == 0 goto done
dec idx
$S1 = substr $S0, idx, 1
if $S1 == '0' goto repl_loop
done:
inc idx
$S0 = substr $S0, 0, idx
$P0 = $S0
%r = $P0
}
}
our sub str2num-rat($negate, $int-part, $frac-part is copy) is export {
$frac-part = chop-trailing-zeros($frac-part);
my $result = upgrade_to_num_if_needed(str2num-int($int-part))
+ upgrade_to_num_if_needed(str2num-int($frac-part))
/ upgrade_to_num_if_needed(str2num-base($frac-part));
$result = -$result if $negate;
$result;
}
our sub str2num-num($negate, $int-part, $frac-part, $exp-part-negate, $exp-part) is export {
my $exp = str2num-int($exp-part);
$exp = -$exp if $exp-part-negate;
my $result = (str2num-int($int-part) + str2num-int($frac-part) / str2num-base($frac-part))
* 10 ** $exp;
$result = -$result if $negate;
$result;
}
}