blob: a16715729f2aaa82a69cf156094bd26172d1b023 (
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
|
(.module:
lux
(lux [io #+ IO]
(control [monad #+ do]
pipe)
(data ["e" error]
text/format
(coll [list]))
["r" math/random]
(lang ["//." synthesis #+ Path Synthesis])
test)
(test/luxc common))
(def: struct-limit Nat +10)
(def: (tail? size idx)
(-> Nat Nat Bool)
(n/= (n/dec size) idx))
(def: gen-case
(r.Random [Synthesis Path])
(<| r.rec (function (_ gen-case))
(`` ($_ r.either
(do r.Monad<Random>
[value r.int]
(wrap [(//synthesis.path/i64 value)
//synthesis.path/pop]))
(~~ (do-template [<gen> <synth> <path>]
[(do r.Monad<Random>
[value <gen>]
(wrap [(<synth> value)
(<path> value)]))]
[r.bool //synthesis.bool //synthesis.path/bool]
[r.int //synthesis.i64 //synthesis.path/i64]
[r.frac //synthesis.f64 //synthesis.path/f64]
[(r.unicode +5) //synthesis.text //synthesis.path/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 (//synthesis.path/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)
(:coerce 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 (:coerce 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)))
|
