1 files changed, 97 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux
new file mode 100644
index 000000000..28bfd36ba
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux
@@ -0,0 +1,97 @@
+(.module:
+  [lux (#- function)
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    pipe]
+   [data
+    ["." product]
+    [text
+     format]
+    [collection
+     ["." list ("#;." functor)]]]
+   [host
+    ["_" scheme (#+ Expression Computation Var)]]]
+  ["." // #_
+   ["#." runtime (#+ Operation Phase)]
+   ["#." reference]
+   ["#." case]
+   ["#/" //
+    ["#." reference]
+    ["#/" // ("#;." monad)
+     ["#/" // #_
+      [reference (#+ Register Variable)]
+      [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)]
+      [synthesis (#+ Synthesis)]]]]])
+
+(def: #export (apply generate [functionS argsS+])
+  (-> Phase (Application Synthesis) (Operation Computation))
+  (do ////.monad
+    [functionO (generate functionS)
+     argsO+ (monad.map @ generate argsS+)]
+    (wrap (_.apply/* functionO argsO+))))
+
+(def: #export capture
+  (///reference.foreign _.var))
+
+(def: (with-closure function-name inits function-definition)
+  (-> Text (List Expression) Computation (Operation Computation))
+  (////;wrap
+   (case inits
+     #.Nil
+     function-definition
+
+     _
+     (let [@closure (_.var (format function-name "___CLOSURE"))]
+       (_.letrec (list [@closure
+                        (_.lambda [(|> (list.enumerate inits)
+                                  (list;map (|>> product.left ..capture)))
+                              #.None]
+                             function-definition)])
+                 (_.apply/* @closure inits))))))
+
+(def: @curried (_.var "curried"))
+(def: @missing (_.var "missing"))
+
+(def: input
+  (|>> inc //case.register))
+
+(def: #export (function generate [environment arity bodyS])
+  (-> Phase (Abstraction Synthesis) (Operation Computation))
+  (do ////.monad
+    [[function-name bodyO] (///.with-context
+                             (do @
+                               [function-name ///.context]
+                               (///.with-anchor (_.var function-name)
+                                 (generate bodyS))))
+     closureO+ (: (Operation (List Expression))
+                  (monad.map @ (:: //reference.system variable) environment))
+     #let [arityO (|> arity .int _.int)
+           apply-poly (.function (_ args func)
+                        (_.apply/2 (_.global "apply") func args))
+           @num-args (_.var "num_args")
+           @function (_.var function-name)]]
+    (with-closure function-name closureO+
+      (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)]
+                                      (_.let (list [@num-args (_.length/1 @curried)])
+                                        (<| (_.if (|> @num-args (_.=/2 arityO))
+                                              (<| (_.let (list [(//case.register 0) @function]))
+                                                  (_.let-values (list [[(|> (list.indices arity)
+                                                                            (list;map ..input))
+                                                                        #.None]
+                                                                       (_.apply/2 (_.global "apply") (_.global "values") @curried)]))
+                                                  bodyO))
+                                            (_.if (|> @num-args (_.>/2 arityO))
+                                              (let [arity-args (//runtime.slice (_.int +0) arityO @curried)
+                                                    output-func-args (//runtime.slice arityO
+                                                                                      (|> @num-args (_.-/2 arityO))
+                                                                                      @curried)]
+                                                (|> @function
+                                                    (apply-poly arity-args)
+                                                    (apply-poly output-func-args))))
+                                            ## (|> @num-args (_.</2 arityO))
+                                            (_.lambda [(list) (#.Some @missing)]
+                                                 (|> @function
+                                                     (apply-poly (_.append/2 @curried @missing)))))
+                                        ))])
+                @function))))