blob: 44df51014ed1270bb3f22dd378ac89446b180d20 (
plain)
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
|
(.module:
lux
(lux [io #+ IO]
(control [monad #+ do]
pipe)
(data ["e" error]
text/format
(coll [list]))
["r" math/random "r/" Monad<Random>]
[macro]
(macro [code])
test)
(luxc [lang]
(lang ["ls" synthesis]))
(test/luxc common))
(def: struct-limit Nat +10)
(def: (tail? size idx)
(-> Nat Nat Bool)
(n/= (n/dec size) idx))
(def: upper-alpha-ascii
(r.Random Nat)
(|> r.nat (:: r.Functor<Random> map (|>> (n/% +91) (n/max +65)))))
(def: gen-case
(r.Random [ls.Synthesis ls.Path])
(<| r.rec (function (_ gen-case))
(`` ($_ r.either
(r/wrap [(' []) (' ("lux case pop"))])
(~~ (do-template [<gen> <synth>]
[(do r.Monad<Random>
[value <gen>]
(wrap [(<synth> value) (<synth> value)]))]
[r.bool code.bool]
[r.nat code.nat]
[r.int code.int]
[r.deg code.deg]
[r.frac code.frac]
[(r.text' upper-alpha-ascii +5) code.text]))
(do r.Monad<Random>
[size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
idx (|> r.nat (:: @ map (n/% size)))
[subS subP] gen-case
#let [caseS (` [(~+ (list.concat (list (list.repeat idx (' []))
(list subS)
(list.repeat (|> size n/dec (n/- idx)) (' [])))))])
caseP (` ("lux case seq"
(~ (if (tail? size idx)
(` ("lux case tuple right" (~ (code.nat idx))))
(` ("lux case tuple left" (~ (code.nat idx))))))
(~ subP)))]]
(wrap [caseS caseP]))
(do r.Monad<Random>
[size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
idx (|> r.nat (:: @ map (n/% size)))
[subS subP] gen-case
#let [caseS (` ((~ (code.nat idx)) (~ (code.bool (tail? size idx))) (~ subS)))
caseP (` ("lux case seq"
(~ (if (tail? size idx)
(` ("lux case variant right" (~ (code.nat idx))))
(` ("lux case variant left" (~ (code.nat idx))))))
(~ subP)))]]
(wrap [caseS caseP]))
))))
(def: (pattern-matching-spec run)
(-> Runner Test)
(do r.Monad<Random>
[[valueS pathS] gen-case
to-bind r.nat]
($_ seq
(test "Can translate pattern-matching."
(|> (run (` ("lux case" (~ valueS)
("lux case alt"
("lux case seq" (~ pathS)
("lux case exec" true))
("lux case seq" ("lux case bind" +0)
("lux case exec" false))))))
(case> (#e.Success valueT)
(:! Bool valueT)
(#e.Error error)
(exec (log! error)
false))))
(test "Can bind values."
(|> (run (` ("lux case" (~ (code.nat to-bind))
("lux case seq" ("lux case bind" +0)
("lux case exec" (0))))))
(case> (#e.Success valueT)
(n/= to-bind (:! Nat valueT))
(#e.Error error)
(exec (log! error)
false))))
)))
(context: "[JVM] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-jvm)))
(context: "[JS] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-js)))
(context: "[Lua] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-lua)))
(context: "[Ruby] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-ruby)))
(context: "[Python] Function."
(<| (times +100)
(pattern-matching-spec run-python)))
(context: "[R] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-r)))
(context: "[Scheme] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-scheme)))
(context: "[Common Lisp] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-common-lisp)))
(context: "[PHP] Pattern-matching."
(<| (times +100)
(pattern-matching-spec run-php)))
|
