blob: 543cbe8993da7ea5077a7719b8f2b1aef9ee125a (
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
|
(.module:
lux
(lux (control [monad #+ do]
pipe)
(data [product]
[text]
text/format
(coll [list "list/" Functor<List> Fold<List>]))
[macro])
(luxc ["&" lang]
(lang ["ls" synthesis]
[".L" variable #+ Variable]
(host ["_" common-lisp #+ Expression @@])))
[//]
(// [".T" reference]
[".T" runtime]))
(def: #export (translate-apply translate functionS argsS+)
(-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression))
(do macro.Monad<Meta>
[functionO (translate functionS)
argsO+ (monad.map @ translate argsS+)]
(wrap (_.funcall argsO+ functionO))))
(def: $curried (_.var "curried"))
(def: $missing (_.var "missing"))
(def: input-declaration
(|>> n/inc referenceT.variable))
(def: (with-closure function-name inits function-definition)
(-> Text (List Expression) Expression (Meta Expression))
(let [$closure (_.var (format function-name "___CLOSURE"))]
(do macro.Monad<Meta>
[]
(case inits
#.Nil
(wrap function-definition)
_
(wrap (_.labels (list [$closure [(|> (list.enumerate inits)
(list/map (|>> product.left referenceT.closure))
_.poly)
function-definition]])
(_.funcall inits (_.function (@@ $closure)))))))))
(def: #export (translate-function translate env arity bodyS)
(-> (-> ls.Synthesis (Meta Expression))
(List Variable) ls.Arity ls.Synthesis
(Meta Expression))
(do macro.Monad<Meta>
[[function-name bodyO] (//.with-sub-context
(do @
[function-name //.context]
(//.with-anchor [function-name +1]
(translate bodyS))))
closureO+ (monad.map @ referenceT.translate-variable env)
#let [arityO (|> arity nat-to-int _.int)
$num_args (_.var "num_args")
$function (_.var function-name)]]
(with-closure function-name closureO+
(_.labels (list [$function [(_.poly+ (list) $curried)
(_.let (list [$num_args (_.length (@@ $curried))])
(<| (_.if (|> (@@ $num_args) (_.= arityO))
(_.let (list [(referenceT.variable +0) (_.function (@@ $function))])
(_.destructuring-bind [(|> (list.n/range +0 (n/dec arity))
(list/map input-declaration)
_.poly)
(@@ $curried)]
bodyO)))
(_.if (|> (@@ $num_args) (_.> arityO))
(let [arity-args (_.subseq/3 (@@ $curried) (_.int 0) arityO)
output-func-args (_.subseq/3 (@@ $curried) arityO (@@ $num_args))]
(|> (_.function (@@ $function))
(_.apply arity-args)
(_.apply output-func-args))))
## (|> (@@ $num_args) (_.< arityO))
(_.lambda (_.poly+ (list) $missing)
(|> (_.function (@@ $function))
(_.apply (_.append (@@ $curried) (@@ $missing)))))))]])
(_.function (@@ $function))))
))
|
