blob: 75736d223e2047912e16c1d10505fb63a0d9d722 (
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
|
(.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)
(-> (-> ls.Synthesis (e.Error Top)) 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] Function."
(<| (times +100)
(pattern-matching-spec run-scheme)))
|
