blob: ace2e0290852264fdfa5eb29b957506c4f068a22 (
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
|
(;module:
lux
(lux [io]
(control [monad #+ do]
pipe)
(data ["e" error]
text/format
(coll [list]))
["r" math/random "r/" Monad<Random>]
[meta]
(meta [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."
(<| (times +100)
(do @
[[valueS pathS] gen-case
to-bind r;nat]
($_ seq
(test "Can translate pattern-matching."
(|> (do meta;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))
(meta;run (init-compiler []))
(case> (#e;Success valueT)
(:! Bool valueT)
(#e;Error error)
false)))
(test "Can bind values."
(|> (do meta;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))
(meta;run (init-compiler []))
(case> (#e;Success valueT)
(n.= to-bind (:! Nat valueT))
_
false)))))))
|
