-
Notifications
You must be signed in to change notification settings - Fork 15
/
CORE.setting
4595 lines (4081 loc) · 151 KB
/
CORE.setting
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
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
# vim: ft=perl6 fdm=marker
my module CORE;
use MONKEY_TYPING;
# The contract for 'is pure' is that, when provided a set of positional and
# named arguments all of which are of immutable types, an immutable object
# is returned which depends only on the arguments, not on any free variables.
# In particular, any function which necessarily takes or returns a List
# is excluded.
# However, slurpy arguments are ok. If an object is claimed to be immutable
# but implements variable methods for Bool,Str,Int,etc, no rules apply.
#
# There are three senses of 'immutability' currently used in Niecza. For an
# expression, being immutable means that the same Variable will always be
# returned (that is, =:=) and there are no side effects, so that expression
# can effectively be constant-folded. const_value will return either a
# Value downvalue or Nil depending on (an approximation to) such immutability.
#
# For values, immutability is measured by the 'immutable' method, and is true
# if none of the object's state, as seen by perl, eqv, or other such accesors,
# can be changed. Variables are immutable if they are read-only and their
# value is immutable. Note that an immutable expression can return a mutable
# variable!
#
# Known suboptimalities of this system: it doesn't make a whole lot of sense
# to be forbidding (3 => 5) but, but allowing (3 => $x) but. Also, we could
# usefully fold some cases like "foo" => &bar, even though &bar is not
# immutable.
# Predeclarations of types {{{
my class Mu { ... }
my grammar Cursor { ... }
my class Regex { ... }
my class Num { ... }
my class Str { ... }
my class Code { ... }
my class Match { ... }
my class List { ... }
my class Array { ... }
my class FatRat { ... }
my class Junction { ... }
my class Enum { ... }
my class Range { ... }
my class Whatever { ... }
my class IO { ... }
our class IO::Path { ... }
my class ObjAt { ... }
my class Proxy { ... }
my class Set { ... }
my class SetHash { ... }
my class Bag { ... }
my class BagHash { ... }
my class Pair { ... }
grammar Niecza::NumSyntax { ... }
# }}}
# Important inlinable definitions {{{
proto infix:<+>($?,$?) is pure is Niecza::builtin('plus',2,2) {*}
multi infix:<+>($l,$r) { $l + $r }
proto infix:<->($?,$?) is pure is Niecza::builtin('minus',2,2) {*}
multi infix:<->($l,$r) { $l - $r }
proto infix:<*> is pure is Niecza::builtin('mul',2,2) is Niecza::absprec<u=> ($?,$?) {*}
multi infix:<*>($l,$r) { $l * $r }
proto infix:</> is pure is Niecza::builtin('divide',2,2) is equiv<*> ($?,$?) {*}
multi infix:</>($l,$r) { $l / $r }
proto infix:<%> is pure is Niecza::builtin('mod',2,2) is equiv<*> ($?,$?) {*}
multi infix:<%>($l,$r) { $l % $r }
proto infix:<**> is pure is Niecza::builtin('pow',2,2) is Niecza::absprec<w= right> ($?,$?) {*}
multi infix:<**>($l,$r) { $l ** $r }
# sub infix:<gcd>($l,$r) is Niecza::builtin('gcd',2,2) { $l gcd $r }
sub infix:<gcd>($l,$r) is pure { Q:CgOp { (gcd {$l.Int} {$r.Int}) } }
sub infix:<lcm>($l,$r) is pure {
my $l-int = $l.Int.abs;
my $r-int = $r.Int.abs;
$l-int div ($l-int gcd $r-int) * $r-int;
}
sub next ($x?) { _lexotic(1, $x, ()) }
sub last ($x?) { _lexotic(2, $x, ()) }
sub redo ($x?) { _lexotic(3, $x, ()) }
sub return(\|@pcl) is return-pass { Q:CgOp {
(control 4 (null frame) (int -1) (null str) {@pcl.unwrap-single})
} }
sub return-rw(\|@pcl) is return-pass { Q:CgOp {
(control 4 (null frame) (int -1) (null str) {@pcl.unwrap-single})
} }
sub succeed(\|@pcl) {
Q:CgOp { (control 6 (null frame) (int -1) (null str) {@pcl.unwrap-single}) }
}
sub proceed() { proceed }
sub term:<proceed>() {
Q:CgOp { (control 7 (null frame) (int -1) (null str) {()}) }
}
sub take(\|@pcl) { Q:CgOp { (take {@pcl.unwrap-single}) } }
sub take-rw(\|@pcl) { Q:CgOp { (take {@pcl.unwrap-single}) } }
sub infix:<&> is pure is Niecza::absprec<q= list> is iffy
(\|$p) { Junction.from-parcel(0, $p) }
sub infix:<|> is pure is Niecza::absprec<p= list> is iffy
(\|$p) { Junction.from-parcel(3, $p) }
sub infix:<^> is pure is equiv<|> (\|$p) { Junction.from-parcel(2, $p) }
sub all (*@p) is pure { all @p }
sub none (*@p) is pure { none @p }
sub one (*@p) is pure { one @p }
sub any (*@p) is pure { any @p }
proto infix:<< == >>($?,$?) is pure is Niecza::builtin('numeq',2,2)
is Niecza::absprec<m= chain> is diffy is iffy {*}
proto infix:<< != >>($?,$?) is pure is Niecza::builtin('numne',2,2)
is equiv<==> {*}
proto infix:<< < >>($?,$?) is pure is Niecza::builtin('numlt',2,2)
is equiv<==> {*}
proto infix:<< > >>($?,$?) is pure is Niecza::builtin('numgt',2,2)
is equiv<==> {*}
proto infix:<< <= >>($?,$?) is pure is Niecza::builtin('numle',2,2)
is equiv<==> {*}
proto infix:<< >= >>($?,$?) is pure is Niecza::builtin('numge',2,2)
is equiv<==> {*}
multi infix:<< == >>($l,$r) { $l == $r }
multi infix:<< != >>(\l,\r) { l != r } # Needs special handling of junctions
multi infix:<< < >>($l,$r) { $l < $r }
multi infix:<< > >>($l,$r) { $l > $r }
multi infix:<< <= >>($l,$r) { $l <= $r }
multi infix:<< >= >>($l,$r) { $l >= $r }
proto infix:<ge>($?,$?) is Niecza::builtin('strge',2,2) is equiv<==> is pure {*}
proto infix:<gt>($?,$?) is Niecza::builtin('strgt',2,2) is equiv<==> is pure {*}
proto infix:<le>($?,$?) is Niecza::builtin('strle',2,2) is equiv<==> is pure {*}
proto infix:<lt>($?,$?) is Niecza::builtin('strlt',2,2) is equiv<==> is pure {*}
proto infix:<eq>($?,$?) is Niecza::builtin('streq',2,2) is equiv<==> is pure {*}
proto infix:<ne>($?,$?) is Niecza::builtin('strne',2,2) is equiv<==> is pure {*}
multi infix:<ge>($s1, $s2) { $s1 ge $s2 }
multi infix:<gt>($s1, $s2) { $s1 gt $s2 }
multi infix:<le>($s1, $s2) { $s1 le $s2 }
multi infix:<lt>($s1, $s2) { $s1 lt $s2 }
multi infix:<eq>($s1, $s2) { $s1 eq $s2 }
multi infix:<ne>(\s1, \s2) { s1 ne s2 } # Needs special handling of junctions
sub infix:<,> is Niecza::builtin('comma',0) is pure is Niecza::absprec<g= list> (\|$t) { Q:CgOp { (newrwlistvar (@ {$t})) }; }
proto infix:<=>($?,$?) is Niecza::absprec<i= right> is Niecza::builtin('assign',2,2) {*}
multi infix:<=>(\a, \b) { a = b }
sub chars($str) is pure is Niecza::builtin('chars',1,1) { chars($str) }
sub codes($str) is pure is Niecza::builtin('codes',1,1) { codes($str) }
sub defined(\x) is pure is Niecza::builtin('defined',1,1) { defined(x) }
sub prefix:<~>(\v) is pure is Niecza::builtin('asstr', 1, 1) { ~v }
sub prefix:<?>(\v) is pure is Niecza::builtin('asbool', 1, 1) { ?v }
sub prefix:<->(\v) is pure is Niecza::builtin('negate', 1, 1) { -v }
sub prefix:<+>(\v) is pure is Niecza::builtin('num', 1, 1) { +v }
sub prefix:<!>(\v) is pure is Niecza::builtin('not', 1, 1) { !v }
sub not(\v) is pure is Niecza::builtin('not', 1, 1) { not(v) }
sub so(\v) is pure is Niecza::builtin('asbool', 1, 1) { so v }
proto infix:<+&> is pure is Niecza::builtin('numand',2,2) is equiv<*> ($?,$?) {*}
proto infix:<+|>($?,$?) is pure is Niecza::builtin('numor',2,2) {*}
proto infix:<+^>($?,$?) is pure is Niecza::builtin('numxor',2,2) {*}
proto infix:<< +< >>($?,$?) is equiv<*> is pure
is Niecza::builtin('numlshift',2,2) {*}
proto infix:<< +> >>($?,$?) is equiv<*> is pure
is Niecza::builtin('numrshift',2,2) {*}
proto prefix:<< +^ >>(|) is Niecza::builtin('numcompl',1,1) is pure {*}
multi infix:<+&> ($x, $y) { $x +& $y }
multi infix:<+|>($x, $y) { $x +| $y }
multi infix:<+^>($x, $y) { $x +^ $y }
multi infix:<< +< >>($x, $y) { $x +< $y }
multi infix:<< +> >>($x, $y) { $x +> $y }
multi prefix:<< +^ >>($x) { +^$x }
sub infix:<< => >>($k, Mu $v) is equiv<=> is pure
is Niecza::builtin('pair', 2, 2) { $k => $v }
sub postcircumfix:<[ ]>(\container, |stuff) {
container.postcircumfix:<[ ]>(|stuff)
}
sub postcircumfix:<{ }>(\container, |stuff) {
container.postcircumfix:<{ }>(|stuff)
}
sub push(@array, *@stuff) is Niecza::builtin('push', 1) { @array.push(@stuff) }
sub unshift(@array, *@stuff) is Niecza::builtin('unshift', 1) { @array.unshift(@stuff) }
sub pop(@array) is Niecza::builtin('pop', 1, 1) { @array.pop }
sub shift(@array) is Niecza::builtin('shift', 1, 1) { @array.shift }
multi sub splice(@array is rw) { @array.splice() }
multi sub splice(@array is rw, *@values) { @array.splice(@values) }
multi sub splice(@array is rw, $offset, *@values) { @array.splice($offset,Inf,@values); }
multi sub splice(@array is rw, $offset, $size, *@values) { @array.splice($offset, $size, @values); }
sub grep(Mu $filter, *@items) is Niecza::builtin('grep',1) { grep($filter, @items) }
sub map($callback, *@items) is Niecza::builtin('map',1) { map($callback, @items) }
sub _array_constructor(\parcel) is Niecza::builtin('array_constructor', 1,
1) { _array_constructor(parcel) }
sub make($x) is Niecza::builtin('make', 1, 1) { make $x }
# these are defined in terms of other operators so they go at the end
sub prefix:<--> is Niecza::absprec<x= unary non> is Niecza::builtin('predec',1,1) ($v is rw) { $v = $v.pred; $v }
sub prefix:<++> is equiv<--> is Niecza::builtin('preinc',1,1) ($v is rw) { $v = $v.succ; $v }
sub postfix:<--> is Niecza::absprec<x= unary non> is Niecza::builtin('postdec',1,1) ($v is rw) { my $old = $v; $v = $v.pred; $old }
sub postfix:<++> is equiv<--> is Niecza::builtin('postinc',1,1) ($v is rw) { my $old = $v; $v = $v.succ; $old }
sub substr(\str, $start, $len?, $repl?) is Niecza::builtin('substr_ro3', 3, 3) is pure {
$start := $start(chars str) if $start.^does(Code);
$len := $len.^does(Code) ?? ($len(chars str) - $start) !!
$len // (chars(str) - $start);
defined($repl) ??
substr-rw(str, $start, $len) = $repl !!
substr(str, $start, $len)
}
# Right now, this compltely duplicates the code of substr. substr needs to be fixed so
# that it isn't an lvalue, and the code below should remain substr-rw.
sub substr-rw(\str, $start, $len?, $repl?) is Niecza::builtin('substr3', 3, 3) is pure {
$start := $start(chars str) if $start.^does(Code);
$len := $len.^does(Code) ?? ($len(chars str) - $start) !!
$len // (chars(str) - $start);
defined($repl) ??
substr-rw(str, $start, $len) = $repl !!
substr-rw(str, $start, $len)
}
# not actually inlined but needed for constant i
sub sqrt($x) is pure { Q:CgOp { (sqrt {$x}) } }
sub Niecza::toggle_mono_trace() { Q:CgOp { (prog (raise (s "SIGUSR2")) {0}) } }
sub infix:<X>(\|$pcl) is Niecza::absprec<f= list> {
Q:CgOp { (cross (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub infix:<Z>(\|$pcl) is equiv<X> {
Q:CgOp { (zip (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub zipop(\|$pcl) {
Q:CgOp { (zip (b 1) (unbox fvarlist (@ {$pcl}))) }
}
sub crossop(\|$pcl) {
Q:CgOp { (cross (b 1) (unbox fvarlist (@ {$pcl}))) }
}
# }}}
# Fundamental types {{{
my constant True = 1.Bool;
my constant False = 0.Bool;
my class Mu {
method head() { @(self).head }
method flattens(\:) {
Q:CgOp { (box Bool (var_islist {self})) }
}
method typename() { # should be ^name
Q:CgOp { (box Str (obj_typename (@ {self}))) }
}
method gist() { defined(self) ?? self.perl !! '(' ~ self.typename ~ ')' }
method say() { self.gist.say }
method print() { $*OUT.print(self) }
method Stringy() { self.Str }
method Str() {
if defined(self) {
my $tn := Q:CgOp { (box Str (obj_typename (@ {self}))) };
$tn ~ "()<instance>"
} else {
warn "Use of uninitialized value in string context";
""
}
}
method succ() { defined(self) ?? die("cannot increment a value of type {self.typename()}") !! 1 }
method pred() { defined(self) ?? die("cannot decrement a value of type {self.typename()}") !! -1 }
method notdef() { !defined(self) }
method ACCEPTS(\x) { defined(self) ?? self === x !! x.^does(self) }
method perl() { defined(self) ?? "{self.typename}.new(...)" !! self.typename }
method so() { ?self }
method not() { !self }
multi method bless($, *%_) {
warn "Passing an object candidate to Mu.bless is deprecated";
Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) }
}
multi method bless(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
method CREATE() { Q:CgOp { (obj_newblank (obj_llhow (@ {self}))) } }
multi method new(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
method clone(*%_) { Q:CgOp { (repr_clone (@ {self}) (unbox varhash (@ {%_}))) } }
method dispatch:<::>(|) { Q:CgOp { (dispatch_fromtype) } }
method immutable() { !defined(self) }
method take() { take self }
multi method WHICH() { ObjAt.new(str => '', ref => self) }
}
my class Any is Mu {
method isa(\other) { self.^isa(other) }
method does(\other) { self.^does(other) }
method can($method) { self.^can($method) }
method flat() { @(self) }
method Numeric() {
die "Cannot use value like $.typename as a number" if defined(self);
warn "Use of uninitialized value in numeric context";
0;
}
# This needs a way of taking a user-defined comparison
# specifier, but AFAIK nothing has been spec'd yet.
# CHEAT: Almost certainly should be hashed on something
# other than the stringification of the objects.
method uniq() {
my %seen;
gather for @(self) {
unless %seen{$_} {
take $_;
%seen{$_} = 1;
}
}
}
method kv() {
my $i = 0;
gather for @(self) -> \value {
my $key = $i++;
take $key;
take value;
}
}
method keys() {
my $i = 0;
gather for @(self) -> $value { #OK not used
my $key = $i++;
take $key;
}
}
method values() {
gather for @(self) -> \value {
take value;
}
}
method pairs() {
self.kv.map(-> $key, \value { $key => value; });
}
# NOTE: These functions are called by the default postcircumfixes, *after*
# processing slicing and adverbs. So you should probably override these
# instead. However, for speed, Array, Hash et al override the
# postcircumfixes instead, and so you can't change their behavior using
# delete_key and company in subclasses.
method delete_key($) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method exists_key($) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method at_key($) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method bind_key($, $) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method at_pos($key) { self.list.at_pos($key) }
method bind_pos($, $) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method grep(Mu $sm) { grep $sm, @(self) }
method map($func) { map $func, @(self) }
method for (&cb) {
Q:CgOp {
(rnull (letn it (unbox vvarlist (@ {self.iterator}))
cb (@ {&cb})
(whileloop 0 0 (iter_hasflat (l it))
(sink (subcall (l cb) (vvarlist_shift (l it)))))))
};
}
method elems() { self.flat.elems }
method end() { self.defined ?? self.elems - 1 !! -1 }
method iterator() { self.flat.iterator }
method join($sep = "") { self.flat.join($sep) }
method chrs() { chrs(@(self)) }
method any() { any @(self) }
method none() { none @(self) }
method all() { all @(self) }
method one() { one @(self) }
method sort($cmp = &infix:<cmp>) { @(self).sort($cmp) }
method first(Mu $filter) { for @(self) { return $_ if $_ ~~ $filter } }
method !butWHENCE($cr) {
Q:CgOp { (newvsubvar (class_ref mo Any) (@ {$cr}) (@ {self})) }
}
method hash() { anon %hash = @(self) }
multi method roll($num = 1) {
return { self[floor(self.elems.rand)] } xx * if $num ~~ Whatever;
return self[floor(self.elems.rand)] if $num == 1;
return map { self[floor(self.elems.rand)] }, ^$num;
}
multi method pick($num is copy = 1) {
my @l = @(self);
if ($num ~~ Whatever) {
$num = @l.elems;
} elsif ($num == 1) {
return @l[floor(@l.elems.rand)];
}
my $number-elements = @l.elems;
gather {
while ($num > 0 and $number-elements > 0) {
my $idx = floor($number-elements.rand());
my $old = @l[$idx];
@l[$idx] = @l[--$number-elements];
take $old;
--$num;
}
}
}
method rotate($n = 1) { @(self).rotate($n) }
method min($cmp = &infix:<cmp>) { @(self).min($cmp) }
method max($cmp = &infix:<cmp>) { @(self).max($cmp) }
method minmax($cmp = &infix:<cmp>) { @(self).minmax($cmp) }
method reduce($expression) {
my $result;
my $first = 1;
for @(self) -> $cur {
if $first {
$result = $cur;
$first = 0;
next;
}
$result = &$expression($result, $cur);
}
$result;
}
method classify($test) { {}.classify( $test, @(self) ) }
}
sub Niecza::autopun($pun, $name) {
-> | { Q:CgOp { (rnull (pun_helper {$pun} {$name} (callframe))) }; nextsame }
}
sub IMMUTABLE(\x) { Q:CgOp { (ternary (var_is_rw {x}) {False} {x.immutable}) } }
my class Empty {
method new() { Empty }
method iterator() { ().iterator }
method gist() { '' }
method Str() { '' }
method flat() { self.iterator.flat }
method list() { self.iterator.list }
method at_pos($key) { @(self).[$key] }
method Capture () { ().Capture }
method elems () { 0 }
method Numeric() { 0 }
method Bool () { ?0 }
}
my class Nil {
method new() { Nil }
method iterator() { ().iterator }
method gist() { 'Nil' }
# XXX the default won't work because of Nil's exotic binding behavior
multi method WHICH() { ObjAt.new(str => 'Nil', ref => Any) }
method Str() { warn "Use of Nil as a string"; '' }
method flat() { self.iterator.flat }
method list() { self.iterator.list }
method at_pos($key) { @(self).[$key] }
method Capture () { ().Capture }
method elems () { 0 }
method Numeric() { warn "Use of Nil as a number"; 0 }
method Bool () { ?0 }
method FALLBACK (|) { Nil }
}
my class Cool {
method FatRat () { Niecza::NumSyntax.str2num(~self, :fatrat) }
method Rat($eps = 1e-6) { Q:CgOp { (rat_approx {self} {$eps}) } }
method Int() { Q:CgOp { (coerce_to_int {self}) } }
method Num() { Q:CgOp { (coerce_to_num {self}) } }
method IO() { self.Str.IO }
method abs() { abs self }
method floor() { floor self }
method ceiling() { ceiling self }
method round($scale = 1) { round self, $scale }
method truncate() { truncate self }
method sqrt() { sqrt self }
method sign() { sign self }
method conj() { self }
multi method exp() { Q:CgOp { (exp {self}) } }
multi method exp($base) { $base ** self }
method ln() { Q:CgOp { (ln {self}) } }
multi method log() { self.ln }
multi method log($base) { self.ln / $base.ln }
method log10() { self.ln / 10.ln }
method sin() { Q:CgOp { (sin {self}) } }
method asin() { Q:CgOp { (asin {self}) } }
method cos() { Q:CgOp { (cos {self}) } }
method acos() { Q:CgOp { (acos {self}) } }
method tan() { Q:CgOp { (tan {self}) } }
method atan() { Q:CgOp { (atan {self}) } }
method sec() { Q:CgOp { (sec {self}) } }
method asec() { Q:CgOp { (asec {self}) } }
method cosec() { Q:CgOp { (cosec {self}) } }
method acosec() { Q:CgOp { (acosec {self}) } }
method cotan() { Q:CgOp { (cotan {self}) } }
method acotan() { Q:CgOp { (acotan {self}) } }
method sinh() { Q:CgOp { (sinh {self}) } }
method asinh() { Q:CgOp { (asinh {self}) } }
method cosh() { Q:CgOp { (cosh {self}) } }
method acosh() { Q:CgOp { (acosh {self}) } }
method tanh() { Q:CgOp { (tanh {self}) } }
method atanh() { Q:CgOp { (atanh {self}) } }
method sech() { Q:CgOp { (sech {self}) } }
method asech() { Q:CgOp { (asech {self}) } }
method cosech() { Q:CgOp { (cosech {self}) } }
method acosech() { Q:CgOp { (acosech {self}) } }
method cotanh() { Q:CgOp { (cotanh {self}) } }
method acotanh() { Q:CgOp { (acotanh {self}) } }
method atan2($x = 1) { Q:CgOp { (atan2 {self} {$x}) } }
method polar() { self.abs, atan2(0, self); }
method unpolar($angle) { unpolar(self, $angle); }
method cis() { cis(self); }
method rand() { self * rand; }
method roots($n) { roots(self, $n); }
method gamma() { Q:CgOp { (gamma {self}) } }
method lgamma() { Q:CgOp { (lgamma {self}) } }
method expm1() { Q:CgOp { (expm1 {self}) } }
method log1p() { Q:CgOp { (log1p {self}) } }
method erf() { Q:CgOp { (erf {self}) } }
method split($matcher, $limit?, :$all?) {
my $matchrx = (($matcher ~~ Regex) ?? $matcher !! /$matcher/);
my $str = ~self;
my $C = Cursor.cursor_start($str);
my @out;
my $i = 0;
my $last = 0;
my $limctr = $limit ~~ Whatever ?? Inf !! $limit // Inf;
my $M;
while ($i <= chars $str) && ($limctr > 1) {
$M = head($matchrx($C.cursor($i++)));
if $M {
push @out, substr($str, $last, ($M.from - $last));
push @out, $M if $all;
$i = $i max ($last = $M.to);
$limctr = ($limctr - 1);
}
}
push @out, substr($str, $last, (chars($str) - $last));
@out;
}
sub _match_nth($ix, @nth) {
shift @nth while @nth && @nth[0] < $ix;
@nth && @nth[0] == $ix;
}
method match($pat, :st(:rd(:nd(:th(:$nth)))), :c(:$continue), :p(:$pos)) {
my $ix = $continue // $pos // 0;
my $str = ~self;
if $ix && ($ix === ?1) {
$ix = CALLER::CALLER::<$/> ?? CALLER::CALLER::<$/>.to !! 0;
}
my $max = chars $str;
my $incr = Cursor.cursor_start($str);
my $indx = 0;
$nth := [ @$nth ] if defined($nth);
while $ix <= $max {
my $mat = head($pat.($incr.cursor($ix++)));
if $mat && (!defined($nth) || _match_nth(++$indx, $nth)) {
Q:CgOp { (rnull (set_status (s $/) {$mat})) };
return unitem($mat);
}
$ix = $ix max $mat.to if defined $mat;
$ix = $max + 1 if defined($pos);
}
Q:CgOp { (rnull (set_status (s $/) {Nil})) };
Nil;
}
method subst(\: $matcher_, $replacement, :g(:$global), :$x,
:c(:$continue), :th(:st(:nd(:rd(:$nth)))), :p(:$pos), :$inplace) {
die ":pos may not be used with :continue" if
defined($pos) && defined($continue);
die ":x may not be used with :global" if defined($x) && $global;
my $old := CALLER::<$/>;
LEAVE CALLER::<$/> := $old unless $inplace;
my $str = ~self;
my $C = Cursor.cursor_start($str);
my $matcher = $matcher_ ~~ Regex ?? $matcher_ !! /$matcher_/;
my $i = $pos // $continue // 0;
if ($i === ?1) {
$i = $old ?? $old.to !! 0;
}
$nth := [ @$nth ] if defined $nth;
my $to = 0;
my $changes = 0;
my $limctr = ($global || defined($x) && $x ~~ Whatever) ?? Inf
!! defined($x) ?? $x.niecza_quantifier_max !! 1;
my @out;
my $index = 0;
while $i < chars($str) && $limctr {
my $M = head($matcher($C.cursor($i++)));
if $M && $M.chars {
Q:CgOp { (rnull (set_status (s '$/') {$M})) };
$i = $M.to max $i;
unless defined($nth) && !_match_nth(++$index, $nth) {
$changes++;
push @out, substr($str,$to,$M.from-$to);
push @out, ($replacement ~~ Str ?? $replacement
!! $replacement.count == 1 ?? $replacement($M) !! $replacement());
$to = $i = $M.to;
$limctr = $limctr - 1;
}
} else {
last if defined($pos);
}
}
my $res = join "", @out, substr($str,$to,chars($str)-$to);
if defined($x) && $changes !~~ $x {
$res = $str;
}
if $inplace {
self = $res;
?$changes;
} else {
$res;
}
}
method wordcase() { self.lc.subst(:g, /\w+/, { tclc $/ }) }
method index($substring, $pos?) {
my $str = ~self;
my $fromc = defined($pos) ?? ($pos min chars $str) !! 0;
my $len = chars $substring;
my $maxi = chars($str) - $len;
while $fromc <= $maxi {
if substr($str,$fromc,$len) eq $substring {
return $fromc;
}
$fromc++;
}
Num; # XXX StrPos
}
method rindex($substring, $from?) {
my $str = ~self;
my $len = chars $substring;
my $fromc = (($from // 1_000_000_000) min (chars($str) - $len));
while $fromc >= 0 {
if substr($str,$fromc,$len) eq $substring {
return $fromc;
}
$fromc = $fromc - 1;
}
Num; # XXX StrPos
}
method comb($matcher = /./, $limit?, :$match) {
my $str = ~self;
my $C = Cursor.cursor_start($str);
my $i = 0;
my $limctr = $limit ~~ Whatever ?? Inf !! $limit // Inf;
my @out;
while ($i < chars $str) && $limctr > 0 {
my $M = head($matcher($C.cursor($i++)));
if $M {
$i max= $M.to;
push @out, ($match ?? $M !! (~$M));
$limctr = $limctr - 1;
}
}
@out
}
method lines($limit = *) {
self.comb(/ ^^ \N* /, $limit);
}
method words($limit = 1_000_000_000) {
self.comb(/ \S+ /, $limit);
}
method words-val() { map &val, self.words }
method chars() { chars(self) }
method codes() { codes(self) }
method chomp() {
my $s = ~self;
my $l = chars($s);
--$l if $l && substr($s, $l-1, 1) eq "\x0A";
--$l if $l && substr($s, $l-1, 1) eq "\x0D";
substr($s,0,$l);
}
method p5chomp($self is rw:) {
my $s = ~$self;
my $l = chars($s);
my $ol = $l;
--$l if $l && substr($s, $l-1, 1) eq "\x0A";
--$l if $l && substr($s, $l-1, 1) eq "\x0D";
$self = substr($s,0,$l);
$ol - $l;
}
method chop() {
my $s = ~self;
substr($s, 0, chars($s) - 1)
}
method p5chop($self is rw:) {
my $str = ~$self;
return '' if $str eq '';
my $end = substr($str, chars($str)-1, 1);
$self = substr($str, 0, chars($str)-1);
$end;
}
method substr(\: $start, $len?, $repl?) {
$start := $start(chars self) if $start.^does(Code);
$len := $len.^does(Code) ?? ($len(chars self) - $start) !!
$len // (chars(self) - $start);
defined($repl) ??
substr(self, $start, $len) = $repl !!
substr(self, $start, $len)
}
method lc() { Q:CgOp { (box Str (str_tolower (obj_getstr {self}))) }}
method uc() { Q:CgOp { (box Str (str_toupper (obj_getstr {self}))) }}
method tc() {
self ~~ /^(.)(.*)$/ ?? Q:CgOp { (box Str (ucd_titlecase { $0.ord })) } ~ $1 !! "";
}
method tclc() {
self ~~ /^(.)(.*)$/ ?? Q:CgOp { (box Str (ucd_titlecase { $0.ord })) } ~ $1.lc !! "";
}
method flip() { Q:CgOp { (box Str (str_flip (obj_getstr {self}))) }}
method lcfirst() { lcfirst(self) }
method ord() { ord(self) }
method chr() { chr(self) }
method ords() { ords(self) }
method trim-leading () { self.subst(/^ \s+/, "") }
method trim-trailing() { self.subst(/\s+ $/, "") }
method trim () { self.trim-leading.trim-trailing }
method EVAL() { EVAL(~self) }
method fmt(Str $format = '%s') {
sprintf($format, self);
}
method trans(*@changes) {
Niecza-trans(self, @changes);
}
method Set() {
my @keys;
for self.list() {
when Pair { @keys.push(.key) if .value; }
default { @keys.push($_) }
}
Set.new(@keys);
}
method SetHash() {
my @keys;
for self.list() {
when Pair { @keys.push(.key) if .value; }
default { @keys.push($_) }
}
SetHash.new(@keys);
}
method Bag() { Bag.new-from-pairs(self.list); }
method BagHash() { BagHash.new-from-pairs(self.list); }
}
my role Positional { Any }
my role Associative { Any }
my class Capture does Positional does Associative {
has $!positionals;
has $!named;
method Parcel() {
Q:CgOp { (box Parcel (getslot Capture $!positionals fvarlist (@ {self}))) }
}
method perl() {
self // return self.typename;
my $pos = self.Parcel.perl;
$pos = substr($pos, 2, chars($pos) - 3);
$pos = substr($pos, 0, chars($pos) - 2) if substr($pos, chars($pos) - 2, 2) eq ', ';
my $h := self.hash;
if $h {
$pos ~= ", " if $pos ne "";
$pos ~= "|" ~ $h.perl;
}
'\(' ~ $pos ~ ')';
}
method immutable() {
self // return True;
self.Parcel.immutable &&
(!self.hash || self.hash.values.Capture.Parcel.immutable);
}
method Capture () { self }
method item () {
if self.hash || self.Parcel.raw_elems != 1 {
die "Can only use .item on captures representing a single value"
}
self.Parcel.raw_at(0)
}
method list () { @(self.Parcel) }
method hash () { unitem( Q:CgOp {
(letn h (getslot Capture $!named varhash (@ {self}))
(ternary (== (l h) (null varhash)) {{}} (box Hash (l h))))
}) }
}
# }}}
# Scalar types {{{
my role Numeric is Cool {
method ACCEPTS(\t) {
defined(self) ?? (self == self ?? self == t !! t != t)
!! t.^does(self)
}
}
my role Real does Numeric {
method Bridge() {
self.Num;
}
method Complex() {
Q:CgOp { (complex_new {self.Bridge} {0}) };
}
method Str() {
self.Bridge.Str;
}
method Bool() {
self != 0;
}
method succ() {
self.Bridge + 1;
}
method pred() {
self.Bridge - 1;
}
}
my role Integral does Real { Any }
my class Num does Real {
method new() { 0e0 }
method immutable() { True }
multi method WHICH(Num:D:) { ObjAt.new(str => ~self, ref => self.WHAT) }
our constant pi = 3.14159_26535_89793_238e0;
our constant e = 2.71828_18284_59045_235e0;
our constant i = Q:CgOp { (complex_new {0} {1}) };
method Num() { self }
method FatRat() { self.Rat(0).FatRat }
method gist() { self.Str }
method perl() {
if defined(self) {
my $num = self.Str;
$num ~= 'e0' unless $num ~~ m:i/e/ || $num ~~ /Inf/ || $num ~~ /NaN/;
$num;
} else {
self.typename;
}
}
}
our constant pi = 3.14159_26535_89793_238e0;
our constant e = 2.71828_18284_59045_235e0;
our constant i = Num::i;
my class Int does Integral {
method new() { 0 }
method immutable() { True }
multi method WHICH(Int:D:) { ObjAt.new(str => ~self, ref => self.WHAT) }
method niecza_quantifier_max() { self }
method niecza_quantifier_min() { self }
method Bridge() { self.Num }
method Int() { self }
method perl() { defined(self) ?? ~self !! self.typename }
method FatRat() { FatRat.new(self, 1) }
method base(Cool $base) {
my $intBase = $base;
die("base must be between 2 and 36, got $base")
unless 2 <= $intBase <= 36;
my @conversion = 0..9, 'A' .. 'Z';
my @res;
my $n = self.abs;
repeat {
push @res, @conversion[$n % $intBase];
$n div= $intBase;
} while $n > 0;
push @res, '-' if self < 0;
join '', @res.reverse;
}
method expmod($power, $mod) { expmod(self, $power, $mod) }
method is-prime($tries = 100) { is-prime(self, $tries) }
method lsb() {
return Nil if self == 0;
Q:CgOp { (lsb {self.abs}) }
}
method msb() {
return Nil if self == 0;
return 0 if self == -1;
my $x = self < 0 ?? (self + 1) * -2 !! self;
Q:CgOp { (msb {$x}) }
}
}
sub Niecza::RatToStr ($rat, :$all) {
my $s = $rat.numerator < 0 ?? '-' !! '';
my $r = $rat.abs;
my $i = $r.floor;
$r -= $i;
$s ~= $i;
if $r {
$s ~= '.';
my $want = $all ?? Inf
!! $rat.denominator < 100_000
?? 6
!! $rat.denominator.Str.chars + 1;
sub CAN-HAZ-MOAR {
my $den = $r.denominator;
$den /= 2 while $den %% 2;
$den /= 5 while $den %% 5;
return False unless $den == 1;
$want = Inf;
return True;
}
my $f = '';
while $r and ($f.chars < $want || CAN-HAZ-MOAR) {
$r *= 10;
$i = $r.floor;
$f ~= $i;
$r -= $i;
}
$f++ if 2 * $r >= 1;
$s ~= $f;
}
$s;
}
my class Rat does Real {
method new($n,$d) { $n / $d }
method immutable() { True }
multi method WHICH(Rat:D:) { ObjAt.new(str => self.perl, ref => self.WHAT) }
multi method Str() { defined(self) ?? Niecza::RatToStr(self) !! "self.typename" }
method perl() {
return self.typename if !defined(self);
my $den = self.denominator;
$den /= 2 while $den %% 2;
$den /= 5 while $den %% 5;
if $den == 1 {
my $str = Niecza::RatToStr(self, :all);
$str ~= ".0" unless $str ~~ /\./;
$str;
} else {
"<" ~ self.numerator ~ "/" ~ self.denominator ~ ">";
}
}
method gist() { self // nextsame; self.Str }
method numerator() { Q:CgOp { (rat_nu {self}) } }
method denominator() { Q:CgOp { (rat_de {self}) } }
method Rat($eps = 1e-6) { self } #OK
method FatRat() { FatRat.new(self.numerator, self.denominator) }
method nude() { [ self.numerator, self.denominator ] }
method norm() { self }
}
my class Complex does Numeric {
method new($re,$im) { Q:CgOp { (complex_new {$re} {$im}) } }
method immutable() { True }
multi method WHICH(Complex:D:) { ObjAt.new(str => self.perl, ref => self.WHAT) }
method perl() { defined(self) ?? "<" ~ self ~ ">" !! self.typename }
method gist() { self // nextsame; self.Str }
method Complex() { self }
method re() { Q:CgOp { (complex_re {self}) } }
method im() { Q:CgOp { (complex_im {self}) } }
method conj() { self.re - (self.im)i }
method polar() { self.abs, atan2(self.im, self.re); }
}
my class FatRat does Real {
method new($n,$d) { FatRat.succ * $n / $d }
method immutable() { True }
multi method WHICH(FatRat:D:) { ObjAt.new(str => self.perl, ref => self.WHAT) }
multi method Str() { defined(self) ?? Niecza::RatToStr(self) !! "self.typename" }
method perl() { defined(self) ?? "FatRat.new({self.numerator}, {self.denominator})" !! self.typename }
method FatRat() { self }
method gist() { self // nextsame; self.Str }
method numerator() { Q:CgOp { (fatrat_nu {self}) } }
method denominator() { Q:CgOp { (fatrat_de {self}) } }
method nude() { [ self.numerator, self.denominator ] }
}
my class Buf { ... }
my class Str is Cool {
method new() { "" }
method immutable() { True }
method ACCEPTS(\t) { defined(self) ?? self eq t !! t.^does(self) }
method chars() { chars(self) }