blob: 3c89ae063579e1bf630661e2c30ef8892ceadc87 (
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
|
(.module:
[lux (#- function)
[control
["." monad (#+ do)]]
[data
["." maybe]
[collection
["." list ("list/." Functor<List> Monoid<List> Fold<List>)]
["dict" dictionary (#+ Dictionary)]]]]
["." // (#+ Synthesis Operation Phase)
["." loop (#+ Transform)]
["/." //
["." analysis (#+ Environment Arity Analysis)]
[//
["." reference (#+ Variable)]]]])
(def: #export nested?
(-> Arity Bit)
(n/> 1))
(def: #export (adjust up-arity after? var)
(-> Arity Bit Variable Variable)
(case var
(#reference.Local register)
(if (and after? (n/>= up-arity register))
(#reference.Local (n/+ (dec up-arity) register))
var)
_
var))
(def: (unfold apply)
(-> Analysis [Analysis (List Analysis)])
(loop [apply apply
args (list)]
(case apply
(#analysis.Apply arg func)
(recur func (#.Cons arg args))
_
[apply args])))
(def: #export (apply synthesize)
(-> Phase Phase)
(.function (_ exprA)
(let [[funcA argsA] (unfold exprA)]
(do ///.Monad<Operation>
[funcS (synthesize funcA)
argsS (monad.map @ synthesize argsA)
locals //.locals]
(case funcS
(^ (//.function/abstraction functionS))
(wrap (|> functionS
(loop.loop (get@ #//.environment functionS) locals argsS)
(maybe.default (//.function/apply [funcS argsS]))))
(^ (//.function/apply [funcS' argsS']))
(wrap (//.function/apply [funcS' (list/compose argsS' argsS)]))
_
(wrap (//.function/apply [funcS argsS])))))))
(def: (prepare up down body)
(-> Arity Arity Synthesis Synthesis)
(if (nested? up)
body
(maybe.default body (loop.recursion down body))))
(def: #export (function synthesize environment body)
(-> Phase Environment Analysis (Operation Synthesis))
(do ///.Monad<Operation>
[direct? //.direct?
arity //.scope-arity
resolver //.resolver
#let [function-arity (if direct?
(inc arity)
1)
up-environment (if (nested? arity)
(list/map (.function (_ closure)
(case (dict.get closure resolver)
(#.Some resolved)
(adjust arity #1 resolved)
#.None
(adjust arity #0 closure)))
environment)
environment)
down-environment (: (List Variable)
(case environment
#.Nil
(list)
_
(|> environment
list.size
list.indices
(list/map (|>> #reference.Foreign)))))
resolver' (if (and (nested? function-arity)
direct?)
(list/fold (.function (_ [from to] resolver')
(dict.put from to resolver'))
//.fresh-resolver
(list.zip2 down-environment up-environment))
(list/fold (.function (_ var resolver')
(dict.put var var resolver'))
//.fresh-resolver
down-environment))]
bodyS (//.with-abstraction function-arity resolver'
(synthesize body))]
(case bodyS
(^ (//.function/abstraction [env' down-arity' bodyS']))
(let [arity' (inc down-arity')]
(|> (prepare function-arity arity' bodyS')
[up-environment arity'] //.function/abstraction
wrap))
_
(|> (prepare function-arity 1 bodyS)
[up-environment 1] //.function/abstraction
wrap))))
|
