Moved function machinery over.

3 files changed, 335 insertions, 222 deletions

diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux
new file mode 100644
index 000000000..741e66573
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux
@@ -0,0 +1,109 @@
+(.module:
+  [lux (#- function)
+   [control
+    ["." monad (#+ do)]
+    pipe]
+   [data
+    ["." product]
+    [text
+     format]
+    [collection
+     ["." list ("#/." functor fold)]]]
+   [host
+    ["_" js (#+ Expression Computation Var)]]]
+  [//
+   ["." runtime (#+ Operation Phase)]
+   ["." reference]
+   ["//." case]
+   ["/." //
+    [common
+     ["common-." reference]]
+    ["//." // ("#/." monad)
+     [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)]
+     [synthesis (#+ Synthesis)]
+     [//
+      [reference (#+ Register Variable)]
+      ["." name]]]]])
+
+(def: #export (apply translate [functionS argsS+])
+  (-> Phase (Application Synthesis) (Operation Computation))
+  (do ////.monad
+    [functionO (translate functionS)
+     argsO+ (monad.map @ translate argsS+)]
+    (wrap (_.apply/* functionO argsO+))))
+
+(def: #export capture
+  (common-reference.foreign _.var))
+
+(def: (with-closure inits function-definition)
+  (-> (List Expression) Computation (Operation Computation))
+  (/////wrap
+   (case inits
+     #.Nil
+     function-definition
+
+     _
+     (let [closure (_.closure (|> (list.enumerate inits)
+                                  (list/map (|>> product.left ..capture)))
+                              (_.return function-definition))]
+       (_.apply/* closure inits)))))
+
+(def: @curried (_.var "curried"))
+
+(def: input
+  (|>> inc //case.register))
+
+(def: @@arguments (_.var "arguments"))
+
+(def: #export (function translate [environment arity bodyS])
+  (-> Phase (Abstraction Synthesis) (Operation Computation))
+  (do ////.monad
+    [[function-name bodyO] (///.with-context
+                             (do @
+                               [function-name ///.context]
+                               (///.with-anchor (_.var function-name)
+                                 (translate bodyS))))
+     closureO+ (: (Operation (List Expression))
+                  (monad.map @ (:: reference.system variable) environment))
+     #let [arityO (|> arity .int _.i32)
+           @num-args (_.var "num_args")
+           @self (_.var function-name)
+           apply-poly (.function (_ args func)
+                        (|> func (_.do "apply" (list _.null args))))
+           initialize-self! (_.define (//case.register 0) @self)
+           initialize! (list/fold (.function (_ post pre!)
+                                    ($_ _.then
+                                        pre!
+                                        (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments))))
+                                  initialize-self!
+                                  (list.indices arity))]]
+    (with-closure closureO+
+      (_.function @self (list)
+        ($_ _.then
+            (_.define @num-args (_.the "length" @@arguments))
+            (_.cond (list [(|> @num-args (_.= arityO))
+                           ($_ _.then
+                               initialize!
+                               (_.return bodyO))]
+                          [(|> @num-args (_.> arityO))
+                           (let [arity-inputs (|> (_.array (list))
+                                                  (_.the "slice")
+                                                  (_.do "call" (list @@arguments (_.i32 +0) arityO)))
+                                 extra-inputs (|> (_.array (list))
+                                                  (_.the "slice")
+                                                  (_.do "call" (list @@arguments arityO)))]
+                             (_.return (|> @self
+                                           (apply-poly arity-inputs)
+                                           (apply-poly extra-inputs))))])
+                    ## (|> @num-args (_.< arityO))
+                    (let [all-inputs (|> (_.array (list))
+                                         (_.the "slice")
+                                         (_.do "call" (list @@arguments)))]
+                      ($_ _.then
+                          (_.define @curried all-inputs)
+                          (_.return (_.closure (list)
+                                               (let [@missing all-inputs]
+                                                 (_.return (apply-poly (_.do ".concat" (list @missing) @curried)
+                                                                       @self))))))))
+            )))
+    ))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux
index fe08b6a50..cc2caf056 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux
@@ -8,20 +8,22 @@
     [text
      format]
     [collection
-     ["." list ("#/." functor)]]]]
+     ["." list ("#/." functor)]]]
+   [host
+    ["_" scheme (#+ Expression Computation Var)]]]
   [//
    ["." runtime (#+ Operation Phase)]
    ["." reference]
+   ["//." case]
    ["/." //
+    [common
+     ["common-." reference]]
     ["//." // ("#/." monad)
      [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)]
      [synthesis (#+ Synthesis)]
      [//
       [reference (#+ Register Variable)]
-      ["." name]
-      [//
-       [host
-        ["_" scheme (#+ Expression Computation Var)]]]]]]])
+      ["." name]]]]])
 
 (def: #export (apply translate [functionS argsS+])
   (-> Phase (Application Synthesis) (Operation Computation))
@@ -30,18 +32,21 @@
      argsO+ (monad.map @ translate argsS+)]
     (wrap (_.apply/* functionO argsO+))))
 
+(def: #export capture
+  (common-reference.foreign _.var))
+
 (def: (with-closure function-name inits function-definition)
   (-> Text (List Expression) Computation (Operation Computation))
-  (let [@closure (_.var (format function-name "___CLOSURE"))]
-    (/////wrap
-     (case inits
-       #.Nil
-       function-definition
+  (/////wrap
+   (case inits
+     #.Nil
+     function-definition
 
-       _
+     _
+     (let [@closure (_.var (format function-name "___CLOSURE"))]
        (_.letrec (list [@closure
                         (_.lambda [(|> (list.enumerate inits)
-                                  (list/map (|>> product.left reference.foreign')))
+                                  (list/map (|>> product.left ..capture)))
                               #.None]
                              function-definition)])
                  (_.apply/* @closure inits))))))
@@ -50,7 +55,7 @@
 (def: @missing (_.var "missing"))
 
 (def: input
-  (|>> inc reference.local'))
+  (|>> inc //case.register))
 
 (def: #export (function translate [environment arity bodyS])
   (-> Phase (Abstraction Synthesis) (Operation Computation))
@@ -60,17 +65,18 @@
                                [function-name ///.context]
                                (///.with-anchor (_.var function-name)
                                  (translate bodyS))))
-     closureO+ (monad.map @ reference.variable environment)
+     closureO+ (: (Operation (List Expression))
+                  (monad.map @ (:: reference.system variable) environment))
      #let [arityO (|> arity .int _.int)
-           @num-args (_.var "num_args")
-           @function (_.var function-name)
            apply-poly (.function (_ args func)
-                        (_.apply/2 (_.global "apply") func args))]]
+                        (_.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 [(reference.local' 0) @function]))
+                                              (<| (_.let (list [(//case.register 0) @function]))
                                                   (_.let-values (list [[(|> (list.indices arity)
                                                                             (list/map ..input))
                                                                         #.None]
@@ -87,6 +93,6 @@
                                             ## (|> @num-args (_.</2 arityO))
                                             (_.lambda [(list) (#.Some @missing)]
                                                  (|> @function
-                                                     (apply-poly (_.append/2 @curried @missing)))))))])
-                @function))
-    ))
+                                                     (apply-poly (_.append/2 @curried @missing)))))
+                                        ))])
+                @function))))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index 89136bb50..4ed7ce96e 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -1,204 +1,202 @@
-(.module:
-  [lux #*
-   [cli (#+ program:)]
-   ["." io (#+ io)]
-   [control
-    [monad (#+ do)]
-    [predicate (#+ Predicate)]]
-   [data
-    [number
-     ["." i64]]]
-   ["." function]
-   ["." math
-    ["r" random (#+ Random) ("#/." functor)]]
-   ["_" test (#+ Test)]
-   ## These modules do not need to be tested.
-   [type
-    [variance (#+)]]
-   [locale (#+)
-    [language (#+)]
-    [territory (#+)]]
-   ## TODO: Test these modules
-   [data
-    [format
-     [css (#+)]
-     [markdown (#+)]]]
-   [host
-    [js (#+)]
-    [scheme (#+)]]
-   [tool
-    [compiler
-     [phase
-      ## [translation
-      ##  [scheme
-      ##   [runtime (#+)]
-      ##   [primitive (#+)]
-      ##   [structure (#+)]
-      ##   [reference (#+)]
-      ##   [case (#+)]]
-      ##  [js
-      ##   [runtime (#+)]
-      ##   [primitive (#+)]
-      ##   [structure (#+)]
-      ##   [reference (#+)]
-      ##   [case (#+)]]]
-      ]]]
-   ## [control
-   ##  ["._" contract]
-   ##  ["._" concatenative]
-   ##  ["._" predicate]
-   ##  [monad
-   ##   ["._" free]]]
-   ## [data
-   ##  ["._" env]
-   ##  ["._" trace]
-   ##  ["._" store]
-   ##  [format
-   ##   ["._" context]
-   ##   ["._" html]
-   ##   ["._" css]
-   ##   ["._" binary]]
-   ##  [collection
-   ##   [tree
-   ##    [rose
-   ##     ["._" parser]]]
-   ##   [dictionary
-   ##    ["._" plist]]
-   ##   [set
-   ##    ["._" multi]]]
-   ##  [text
-   ##   ["._" buffer]]]
-   ## ["._" macro
-   ##  [poly
-   ##   ["._" json]]]
-   ## [type
-   ##  ["._" unit]
-   ##  ["._" refinement]
-   ##  ["._" quotient]]
-   ## [world
-   ##  ["._" environment]
-   ##  ["._" console]]
-   ## [compiler
-   ##  ["._" cli]
-   ##  ["._" default
-   ##   ["._" evaluation]
-   ##   [phase
-   ##    ["._" translation
-   ##     [scheme
-   ##      ["._scheme" function]
-   ##      ["._scheme" loop]
-   ##      ["._scheme" case]
-   ##      ["._scheme" extension]
-   ##      ["._scheme" extension/common]
-   ##      ["._scheme" expression]]]
-   ##    [extension
-   ##     ["._" statement]]]
-   ##   ["._default" cache]]
-   ##  [meta
-   ##   ["._meta" io
-   ##    ["._meta_io" context]
-   ##    ["._meta_io" archive]]
-   ##   ["._meta" archive]
-   ##   ["._meta" cache]]]
-   ## ["._" interpreter
-   ##  ["._interpreter" type]]
-   ]
-  ## TODO: Must have 100% coverage on tests.
-  [/
-   ["/." cli]
-   ["/." io]
-   ["/." host
-    ["/." jvm]]
-   ["/." control]]
-  ## [control
-  ##  [concurrency
-  ##   [promise (#+)]
-  ##   [stm (#+)]
-  ##   ## [semaphore (#+)]
-  ##   ]]
-  ## [data
-  ##  [bit (#+)]
-  ##  [color (#+)]
-  ##  [error (#+)]
-  ##  [name (#+)]
-  ##  [identity (#+)]
-  ##  [lazy (#+)]
-  ##  [maybe (#+)]
-  ##  [product (#+)]
-  ##  [sum (#+)]
-  ##  [number (#+) ## TODO: FIX Specially troublesome...
-  ##   [i64 (#+)]
-  ##   [ratio (#+)]
-  ##   [complex (#+)]]
-  ##  [text (#+)
-  ##   ## [format (#+)]
-  ##   [lexer (#+)]
-  ##   [regex (#+)]]
-  ##  [format
-  ##   ## [json (#+)]
-  ##   [xml (#+)]]
-  ##  ## [collection
-  ##  ##  [array (#+)]
-  ##  ##  [bits (#+)]
-  ##  ##  [list (#+)]
-  ##  ##  [stack (#+)]
-  ##  ##  [row (#+)]
-  ##  ##  [sequence (#+)]
-  ##  ##  [dictionary (#+)
-  ##  ##   ["dictionary_." ordered]]
-  ##  ##  [set (#+)
-  ##  ##   ["set_." ordered]]
-  ##  ##  [queue (#+)
-  ##  ##   [priority (#+)]]
-  ##  ##  [tree
-  ##  ##   [rose (#+)
-  ##  ##    [zipper (#+)]]]]
-  ##  ]
-  ## [math (#+)
-  ##  [random (#+)]
-  ##  [modular (#+)]
-  ##  [logic
-  ##   [continuous (#+)]
-  ##   [fuzzy (#+)]]]
-  ## [macro
-  ##  [code (#+)]
-  ##  [syntax (#+)]
-  ##  [poly
-  ##   ["poly_." equivalence]
-  ##   ["poly_." functor]]]
-  ## [type ## (#+)
-  ##  ## [check (#+)]
-  ##  ## [implicit (#+)] ## TODO: FIX Specially troublesome...
-  ##  ## [resource (#+)]
-  ##  [dynamic (#+)]]
-  ## [time
-  ##  [instant (#+)]
-  ##  [duration (#+)]
-  ##  [date (#+)]]
-  ## [compiler
-  ##  [default
-  ##   ["_default/." syntax]
-  ##   [phase
-  ##    [analysis
-  ##     ["_.A" primitive]
-  ##     ["_.A" structure]
-  ##     ["_.A" reference]
-  ##     ["_.A" case]
-  ##     ["_.A" function]
-  ##     [procedure
-  ##      ["_.A" common]]]
-  ##    [synthesis
-  ##     ["_.S" primitive]
-  ##     ["_.S" structure]
-  ##     ["_.S" case]
-  ##     ["_.S" function]]]]]
-  ## [world
-  ##  [binary (#+)]
-  ##  [file (#+)]
-  ##  [net
-  ##   [tcp (#+)]
-  ##   [udp (#+)]]]
-  )
+(.with-expansions [<host-modules> (.as-is [runtime (#+)]
+                                          [primitive (#+)]
+                                          [structure (#+)]
+                                          [reference (#+)]
+                                          [case (#+)]
+                                          [loop (#+)]
+                                          [function (#+)])]
+  (.module:
+    [lux #*
+     [cli (#+ program:)]
+     ["." io (#+ io)]
+     [control
+      [monad (#+ do)]
+      [predicate (#+ Predicate)]]
+     [data
+      [number
+       ["." i64]]]
+     ["." function]
+     ["." math
+      ["r" random (#+ Random) ("#/." functor)]]
+     ["_" test (#+ Test)]
+     ## These modules do not need to be tested.
+     [type
+      [variance (#+)]]
+     [locale (#+)
+      [language (#+)]
+      [territory (#+)]]
+     ## TODO: Test these modules
+     [data
+      [format
+       [css (#+)]
+       [markdown (#+)]]]
+     [host
+      [js (#+)]
+      [scheme (#+)]]
+     [tool
+      [compiler
+       [phase
+        [translation
+         [scheme
+          <host-modules>]
+         [js
+          <host-modules>]]]]]
+     ## [control
+     ##  ["._" contract]
+     ##  ["._" concatenative]
+     ##  ["._" predicate]
+     ##  [monad
+     ##   ["._" free]]]
+     ## [data
+     ##  ["._" env]
+     ##  ["._" trace]
+     ##  ["._" store]
+     ##  [format
+     ##   ["._" context]
+     ##   ["._" html]
+     ##   ["._" css]
+     ##   ["._" binary]]
+     ##  [collection
+     ##   [tree
+     ##    [rose
+     ##     ["._" parser]]]
+     ##   [dictionary
+     ##    ["._" plist]]
+     ##   [set
+     ##    ["._" multi]]]
+     ##  [text
+     ##   ["._" buffer]]]
+     ## ["._" macro
+     ##  [poly
+     ##   ["._" json]]]
+     ## [type
+     ##  ["._" unit]
+     ##  ["._" refinement]
+     ##  ["._" quotient]]
+     ## [world
+     ##  ["._" environment]
+     ##  ["._" console]]
+     ## [compiler
+     ##  ["._" cli]
+     ##  ["._" default
+     ##   ["._" evaluation]
+     ##   [phase
+     ##    ["._" translation
+     ##     [scheme
+     ##      ["._scheme" function]
+     ##      ["._scheme" loop]
+     ##      ["._scheme" case]
+     ##      ["._scheme" extension]
+     ##      ["._scheme" extension/common]
+     ##      ["._scheme" expression]]]
+     ##    [extension
+     ##     ["._" statement]]]
+     ##   ["._default" cache]]
+     ##  [meta
+     ##   ["._meta" io
+     ##    ["._meta_io" context]
+     ##    ["._meta_io" archive]]
+     ##   ["._meta" archive]
+     ##   ["._meta" cache]]]
+     ## ["._" interpreter
+     ##  ["._interpreter" type]]
+     ]
+    ## TODO: Must have 100% coverage on tests.
+    [/
+     ["/." cli]
+     ["/." io]
+     ["/." host
+      ["/." jvm]]
+     ["/." control]]
+    ## [control
+    ##  [concurrency
+    ##   [promise (#+)]
+    ##   [stm (#+)]
+    ##   ## [semaphore (#+)]
+    ##   ]]
+    ## [data
+    ##  [bit (#+)]
+    ##  [color (#+)]
+    ##  [error (#+)]
+    ##  [name (#+)]
+    ##  [identity (#+)]
+    ##  [lazy (#+)]
+    ##  [maybe (#+)]
+    ##  [product (#+)]
+    ##  [sum (#+)]
+    ##  [number (#+) ## TODO: FIX Specially troublesome...
+    ##   [i64 (#+)]
+    ##   [ratio (#+)]
+    ##   [complex (#+)]]
+    ##  [text (#+)
+    ##   ## [format (#+)]
+    ##   [lexer (#+)]
+    ##   [regex (#+)]]
+    ##  [format
+    ##   ## [json (#+)]
+    ##   [xml (#+)]]
+    ##  ## [collection
+    ##  ##  [array (#+)]
+    ##  ##  [bits (#+)]
+    ##  ##  [list (#+)]
+    ##  ##  [stack (#+)]
+    ##  ##  [row (#+)]
+    ##  ##  [sequence (#+)]
+    ##  ##  [dictionary (#+)
+    ##  ##   ["dictionary_." ordered]]
+    ##  ##  [set (#+)
+    ##  ##   ["set_." ordered]]
+    ##  ##  [queue (#+)
+    ##  ##   [priority (#+)]]
+    ##  ##  [tree
+    ##  ##   [rose (#+)
+    ##  ##    [zipper (#+)]]]]
+    ##  ]
+    ## [math (#+)
+    ##  [random (#+)]
+    ##  [modular (#+)]
+    ##  [logic
+    ##   [continuous (#+)]
+    ##   [fuzzy (#+)]]]
+    ## [macro
+    ##  [code (#+)]
+    ##  [syntax (#+)]
+    ##  [poly
+    ##   ["poly_." equivalence]
+    ##   ["poly_." functor]]]
+    ## [type ## (#+)
+    ##  ## [check (#+)]
+    ##  ## [implicit (#+)] ## TODO: FIX Specially troublesome...
+    ##  ## [resource (#+)]
+    ##  [dynamic (#+)]]
+    ## [time
+    ##  [instant (#+)]
+    ##  [duration (#+)]
+    ##  [date (#+)]]
+    ## [compiler
+    ##  [default
+    ##   ["_default/." syntax]
+    ##   [phase
+    ##    [analysis
+    ##     ["_.A" primitive]
+    ##     ["_.A" structure]
+    ##     ["_.A" reference]
+    ##     ["_.A" case]
+    ##     ["_.A" function]
+    ##     [procedure
+    ##      ["_.A" common]]]
+    ##    [synthesis
+    ##     ["_.S" primitive]
+    ##     ["_.S" structure]
+    ##     ["_.S" case]
+    ##     ["_.S" function]]]]]
+    ## [world
+    ##  [binary (#+)]
+    ##  [file (#+)]
+    ##  [net
+    ##   [tcp (#+)]
+    ##   [udp (#+)]]]
+    ))
 
 (def: identity
   Test