blob: e2ad486132ae535f34015827ba077cff8814d6f1 (
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]
(translation (jvm ["/_jvm" case]
[".T_jvm" expression]
[".T_jvm" eval]
[".T_jvm" runtime])
(js ["/_js" case]
[".T_js" expression]
[".T_js" eval]
[".T_js" runtime])
(lua ["/_lua" case]
[".T_lua" expression]
[".T_lua" eval]
[".T_lua" runtime]))))
(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 [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 +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 translate-expression eval translate-runtime init
translate-case)
(All [a]
(-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
(-> (-> ls.Synthesis (Meta a)) ls.Synthesis ls.Path (Meta a))
Test))
(do r.Monad<Random>
[[valueS pathS] gen-case
to-bind r.nat]
($_ seq
(test "Can translate pattern-matching."
(|> (do macro.Monad<Meta>
[_ translate-runtime
sampleO (translate-case translate-expression
valueS
(` ("lux case alt"
("lux case seq" (~ pathS)
("lux case exec" true))
("lux case seq" ("lux case bind" +0)
("lux case exec" false)))))]
(eval sampleO))
(lang.with-current-module "")
(macro.run (io.run init))
(case> (#e.Success valueT)
(:! Bool valueT)
(#e.Error error)
false)))
(test "Can bind values."
(|> (do macro.Monad<Meta>
[_ translate-runtime
sampleO (translate-case translate-expression
(code.nat to-bind)
(` ("lux case seq" ("lux case bind" +0)
("lux case exec" (0)))))]
(eval sampleO))
(lang.with-current-module "")
(macro.run (io.run init))
(case> (#e.Success valueT)
(n/= to-bind (:! Nat valueT))
(#e.Error error)
false))))))
(context: "[JVM] Pattern-matching."
(<| (times +100)
(pattern-matching-spec expressionT_jvm.translate evalT_jvm.eval runtimeT_jvm.translate init-jvm
/_jvm.translate-case)))
(context: "[JS] Pattern-matching."
(<| (times +100)
(pattern-matching-spec expressionT_js.translate evalT_js.eval runtimeT_js.translate init-js
/_js.translate-case)))
(context: "[Lua] Pattern-matching."
(<| (times +100)
(pattern-matching-spec expressionT_lua.translate evalT_lua.eval runtimeT_lua.translate init-lua
/_lua.translate-case)))
|
