blob: 3bc4664e87bf95020a84f3edd906be27305ec3de (
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
|
(.module:
lux
(lux [io]
(control [monad #+ do]
pipe)
(data ["e" error]
text/format
(coll [list]))
["r" math/random "r/" Monad<Random>]
[macro]
(macro [code])
test)
(luxc (lang ["ls" synthesis]
(translation ["@" case]
[".T" expression]
["@." eval]
["@." runtime]
["@." common])))
(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 (if (tail? size idx)
(` ("lux case tuple right" (~ (code.nat idx)) (~ subP)))
(` ("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 (if (tail? size idx)
(` ("lux case variant right" (~ (code.nat idx)) (~ subP)))
(` ("lux case variant left" (~ (code.nat idx)) (~ subP))))]]
(wrap [caseS caseP]))
))))
(context: "Pattern-matching."
(<| (seed +517905247826)
## (times +100)
(do @
[[valueS pathS] gen-case
to-bind r.nat]
($_ seq
(test "Can translate pattern-matching."
(|> (do macro.Monad<Meta>
[runtime-bytecode @runtime.translate
sampleI (@.translate-case expressionT.translate
valueS
(` ("lux case alt"
("lux case seq" (~ pathS)
("lux case exec" true))
("lux case seq" ("lux case bind" +0)
("lux case exec" false)))))]
(@eval.eval sampleI))
(macro.run (init-compiler []))
(case> (#e.Success valueT)
(:! Bool valueT)
(#e.Error error)
false)))
(test "Can bind values."
(|> (do macro.Monad<Meta>
[runtime-bytecode @runtime.translate
sampleI (@.translate-case expressionT.translate
(code.nat to-bind)
(` ("lux case seq" ("lux case bind" +0)
("lux case exec" (0)))))]
(@eval.eval sampleI))
(macro.run (init-compiler []))
(case> (#e.Success valueT)
(n/= to-bind (:! Nat valueT))
_
false)))))))
|
