Updates for Scheme compiler.

3 files changed, 293 insertions, 161 deletions

diff --git a/lux-scheme/commands.md b/lux-scheme/commands.md
new file mode 100644
index 000000000..055e90d8f
--- /dev/null
+++ b/lux-scheme/commands.md
@@ -0,0 +1,24 @@
+# Scheme compiler
+
+## Test
+
+```
+cd ~/lux/lux-scheme/ && lein lux auto test
+cd ~/lux/lux-scheme/ && lein clean && lein lux auto test
+```
+
+## Build
+
+```
+## Develop
+cd ~/lux/lux-scheme/ \
+&& lein clean \
+&& lein lux auto build
+```
+
+## Try
+
+```
+cd ~/lux/lux-scheme/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux
+```
+
diff --git a/lux-scheme/project.clj b/lux-scheme/project.clj
index ab96d66dc..63cf89031 100644
--- a/lux-scheme/project.clj
+++ b/lux-scheme/project.clj
@@ -22,7 +22,7 @@
   :plugins [[com.github.luxlang/lein-luxc ~version]]
   :dependencies [[com.github.luxlang/luxc-jvm ~version]
                  [com.github.luxlang/stdlib ~version]
-                 [kawa-scheme/kawa-core "2.4"]]
+                 [com.github.arvyy/kawa "3.1.1"]]
 
   :manifest {"lux" ~version}
   :source-paths ["source"]
diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux
index 8eb29a3aa..da9317961 100644
--- a/lux-scheme/source/program.lux
+++ b/lux-scheme/source/program.lux
@@ -1,88 +1,122 @@
 (.module:
   [lux #*
+   [program (#+ program:)]
+   ["." host]
    ["." debug]
-   ["." host (#+ import: interface: do-to object)]
    [abstract
-    [monad (#+ do)]]
+    ["." monad (#+ do)]]
    [control
+    [pipe (#+ exec> case>)]
+    ["." try (#+ Try)]
     ["." exception (#+ exception:)]
     ["." io (#+ IO io)]
-    [parser
-     [cli (#+ program:)]]]
+    [concurrency
+     ["." promise (#+ Promise)]]]
    [data
     ["." maybe]
-    ["." error (#+ Error)]
-    [number
-     ["." i64]]
-    ["." text ("#@." hash)
-     format]
+    ["." text ("#\." hash)
+     ["%" format (#+ format)]
+     ["." encoding]]
     [collection
      ["." array (#+ Array)]]]
    [macro
     ["." template]]
-   [world
-    ["." file]]
-   [target
+   [math
+    [number (#+ hex)
+     ["n" nat]
+     ["." i64]]]
+   ["." world #_
+    ["." file]
+    ["#/." program]]
+   ["@" target
     ["_" scheme]]
    [tool
     [compiler
-     ["." name]
-     ["." synthesis]
-     [phase
-      [macro (#+ Expander)]
-      ["." generation
-       ["." scheme
-        ["." runtime]
-        ["." extension]]]]
+     [phase (#+ Operation Phase)]
+     [reference
+      [variable (#+ Register)]]
+     [language
+      [lux
+       [program (#+ Program)]
+       [generation (#+ Context Host)]
+       ["." synthesis]
+       [analysis
+        [macro (#+ Expander)]]
+       [phase
+        ["." extension (#+ Extender Handler)
+         ["#/." bundle]
+         ["." analysis #_
+          ["#" scheme]]
+         ["." generation #_
+          ["#" scheme]]]
+        [generation
+         ["." reference]
+         ["." scheme
+          ["." runtime]]]]]]
      [default
-      ["." platform (#+ Platform)]]]]]
+      ["." platform (#+ Platform)]]
+     [meta
+      ["." packager #_
+       ["#" script]]]]]]
   [program
    ["/" compositor
-    ["/." cli]]])
+    ["#." cli]
+    ["#." static]]])
 
-(import: #long java/lang/Boolean)
-(import: #long java/lang/String)
+(host.import: java/lang/Boolean)
+(host.import: java/lang/String)
 
-(import: #long (java/lang/Class a))
+(host.import: (java/lang/Class a))
 
-(import: #long java/lang/Object
-  (toString [] java/lang/String)
-  (getClass [] (java/lang/Class java/lang/Object)))
+(host.import: java/lang/Object
+  ["#::."
+   (toString [] java/lang/String)
+   (getClass [] (java/lang/Class java/lang/Object))])
 
-(import: #long java/lang/Long
-  (intValue [] java/lang/Integer))
+(host.import: java/lang/Long
+  ["#::."
+   (intValue [] java/lang/Integer)])
 
-(import: #long java/lang/Integer
-  (longValue [] java/lang/Long))
+(host.import: java/lang/Integer
+  ["#::."
+   (longValue [] java/lang/Long)])
 
-(import: #long gnu/math/IntNum
-  (new #manual [int])
-  (longValue [] long))
+(host.import: gnu/math/IntNum
+  ["#::."
+   (new #manual [int])
+   (longValue [] long)])
 
-(import: #long gnu/math/DFloNum
-  (doubleValue [] double))
+(host.import: gnu/math/DFloNum
+  ["#::."
+   (doubleValue [] double)])
 
-(import: #long gnu/lists/FString
-  (toString [] String))
+(host.import: gnu/lists/FString
+  ["#::."
+   (toString [] String)])
 
-(import: #long gnu/lists/Pair
-  (getCar [] java/lang/Object)
-  (getCdr [] java/lang/Object))
+(host.import: gnu/lists/Pair
+  ["#::."
+   (getCar [] java/lang/Object)
+   (getCdr [] java/lang/Object)])
 
-(import: #long (gnu/lists/FVector E)
-  (getBufferLength [] int)
-  (getRaw [int] E))
+(host.import: (gnu/lists/FVector E)
+  ["#::."
+   (getBufferLength [] int)
+   (getRaw [int] E)])
 
-(import: #long gnu/expr/ModuleMethod
-  (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object))
+(host.import: gnu/mapping/Procedure
+  ["#::."
+   (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object)])
 
-(import: #long gnu/mapping/Environment)
+(host.import: gnu/mapping/Environment)
 
-(import: #long gnu/expr/Language
-  (eval [java/lang/String] #try java/lang/Object))
+(host.import: gnu/expr/Language
+  ["#::."
+   (eval [java/lang/String] #try java/lang/Object)])
 
-(import: #long kawa/standard/Scheme
-  (#static getR7rsInstance [] kawa/standard/Scheme))
+(host.import: kawa/standard/Scheme
+  ["#::."
+   (#static getR7rsInstance [] kawa/standard/Scheme)])
 
 (def: (variant? value)
   (-> Any Bit)
@@ -90,7 +124,7 @@
     (#.Some array)
     ## TODO: Get rid of this coercion ASAP.
     (let [array (:coerce (Array java/lang/Object) array)]
-      (and (n/= 3 (array.size array))
+      (and (n.= 3 (array.size array))
            (case (array.read 0 array)
              (#.Some tag)
              (case (host.check java/lang/Integer tag)
@@ -107,29 +141,30 @@
     false))
 
 (template [<name>]
-  [(interface: <name>
+  [(host.interface: <name>
      (getValue [] java/lang/Object))
 
-   (`` (import: #long (~~ (template.identifier ["program/" <name>]))
-         (getValue [] java/lang/Object)))]
+   (`` (host.import: (~~ (template.identifier ["program/" <name>]))
+         ["#::."
+          (getValue [] java/lang/Object)]))]
 
   [VariantValue]
   [TupleValue]
   )
 
-(def: (variant-value lux-value cdr? value)
+(def: (variant_value lux_value cdr? value)
   (-> (-> java/lang/Object java/lang/Object) Bit (Array java/lang/Object) gnu/lists/Pair)
-  (object [] gnu/lists/Pair [program/VariantValue]
+  (host.object [] gnu/lists/Pair [program/VariantValue]
     []
     ## Methods
     (program/VariantValue
-     (getValue self) java/lang/Object
+     [] (getValue self) java/lang/Object
      (:coerce java/lang/Object value))
     (gnu/lists/Pair
-     (getCar self) java/lang/Object
+     [] (getCar self) java/lang/Object
      (if cdr?
        (case (array.read 1 value)
-         (#.Some flag-is-set)
+         (#.Some flag_is_set)
          (:coerce java/lang/Object "")
          
          #.None
@@ -140,71 +175,71 @@
            (:coerce java/lang/Integer)
            gnu/math/IntNum::new)))
     (gnu/lists/Pair
-     (getCdr self) java/lang/Object
+     [] (getCdr self) java/lang/Object
      (if cdr?
        (|> value
            (array.read 2)
            maybe.assume
-           lux-value)
-       (variant-value lux-value true value)))))
+           lux_value)
+       (variant_value lux_value true value)))))
 
-(def: (tuple-value lux-value value)
+(def: (tuple_value lux_value value)
   (-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector)
-  (object [] gnu/lists/SimpleVector [program/TupleValue]
+  (host.object [] gnu/lists/SimpleVector [program/TupleValue]
     []
     ## Methods
     (program/TupleValue
-     (getValue self) java/lang/Object
+     [] (getValue self) java/lang/Object
      (:coerce java/lang/Object value))
     (gnu/lists/SimpleVector
-     (getBufferLength self) int
-     (host.long-to-int (array.size value)))
+     [] (getBufferLength self) int
+     (host.long_to_int (array.size value)))
     (gnu/lists/SimpleVector
-     (getRaw self {idx int}) java/lang/Object
+     [] (getRaw self {idx int}) java/lang/Object
      (|> value
          (array.read (|> idx java/lang/Integer::longValue (:coerce Nat)))
          maybe.assume
-         lux-value))
+         lux_value))
     (gnu/lists/SimpleVector
-     (getBuffer self) java/lang/Object
-     (error! "tuple-value getBuffer"))
+     [] (getBuffer self) java/lang/Object
+     (undefined))
     (gnu/lists/SimpleVector
-     (setBuffer self {_ java/lang/Object}) void
-     (error! "tuple-value setBuffer"))
+     [] (setBuffer self {_ java/lang/Object}) void
+     (undefined))
     (gnu/lists/SimpleVector
-     (clearBuffer self {_ int} {_ int}) void
-     (error! "tuple-value clearBuffer"))
+     [] (clearBuffer self {_ int} {_ int}) void
+     (undefined))
     (gnu/lists/SimpleVector
-     (copyBuffer self {_ int}) void
-     (error! "tuple-value copyBuffer"))
+     [] (copyBuffer self {_ int}) void
+     (undefined))
     (gnu/lists/SimpleVector
-     (newInstance self {_ int}) gnu/lists/SimpleVector
-     (error! "tuple-value newInstance"))
+     [] (newInstance self {_ int}) gnu/lists/SimpleVector
+     (undefined))
     ))
 
-(exception: (unknown-kind-of-host-object {object java/lang/Object})
+(exception: (unknown_kind_of_host_object {object java/lang/Object})
   (exception.report
    ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
    ["Object" (java/lang/Object::toString object)]))
 
-(exception: (cannot-apply-a-non-function {object java/lang/Object})
+(exception: (cannot_apply_a_non_function {object java/lang/Object})
   (exception.report
    ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
    ["Object" (java/lang/Object::toString object)]))
 
-(def: (lux-value value)
+(def: (lux_value value)
   (-> java/lang/Object java/lang/Object)
   (<| (case (host.check [java/lang/Object] value)
         (#.Some value)
         ## TODO: Get rid of the coercions below.
         (if (variant? value)
-          (variant-value lux-value false (:coerce (Array java/lang/Object) value))
-          (tuple-value lux-value (:coerce (Array java/lang/Object) value)))
+          (variant_value lux_value false (:coerce (Array java/lang/Object) value))
+          (tuple_value lux_value (:coerce (Array java/lang/Object) value)))
         #.None)
       value))
 
 (type: (Reader a)
-  (-> a (Error Any)))
+  (-> a (Try Any)))
 
 (def: (variant tag flag value)
   (-> Nat Bit Any Any)
@@ -215,49 +250,49 @@
         (host.null)))
    value])
 
-(def: (read-variant read host-object)
+(def: (read_variant read host_object)
   (-> (Reader java/lang/Object) (Reader gnu/lists/Pair))
-  (do error.monad
-    [tag (read (gnu/lists/Pair::getCar host-object))
-     #let [host-object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host-object))
-           flag (case (host.check java/lang/String (gnu/lists/Pair::getCar host-object))
+  (do try.monad
+    [tag (read (gnu/lists/Pair::getCar host_object))
+     #let [host_object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host_object))
+           flag (case (host.check java/lang/String (gnu/lists/Pair::getCar host_object))
                   (#.Some _)
                   true
                   
                   #.None
                   false)]
-     value (read (gnu/lists/Pair::getCdr host-object))]
+     value (read (gnu/lists/Pair::getCdr host_object))]
     (wrap (..variant (:coerce Nat tag) flag value))))
 
-(def: (read-tuple read host-object)
+(def: (read_tuple read host_object)
   (-> (Reader java/lang/Object) (Reader (gnu/lists/FVector java/lang/Object)))
-  (let [size (.nat (gnu/lists/FVector::getBufferLength host-object))]
+  (let [size (.nat (gnu/lists/FVector::getBufferLength host_object))]
     (loop [idx 0
            output (: (Array Any)
                      (array.new size))]
-      (if (n/< size idx)
-        (case (read (gnu/lists/FVector::getRaw (.int idx) host-object))
-          (#error.Failure error)
-          (#error.Failure error)
+      (if (n.< size idx)
+        (case (read (gnu/lists/FVector::getRaw (.int idx) host_object))
+          (#try.Failure error)
+          (#try.Failure error)
 
-          (#error.Success lux-value)
-          (recur (inc idx) (array.write idx (: Any lux-value) output)))
-        (#error.Success output)))))
+          (#try.Success lux_value)
+          (recur (inc idx) (array.write! idx (: Any lux_value) output)))
+        (#try.Success output)))))
 
-(def: (read host-object)
+(def: (read host_object)
   (Reader java/lang/Object)
   (`` (<| (~~ (template [<class>]
-                [(case (host.check <class> host-object)
-                   (#.Some host-object)
-                   (#error.Success host-object)
+                [(case (host.check <class> host_object)
+                   (#.Some host_object)
+                   (#try.Success host_object)
                    #.None)]
 
-                [java/lang/Boolean] [java/lang/String] [gnu/expr/ModuleMethod]
+                [java/lang/Boolean] [java/lang/String] [gnu/mapping/Procedure]
                 ))
           (~~ (template [<class> <method>]
-                [(case (host.check <class> host-object)
-                   (#.Some host-object)
-                   (#error.Success (<method> host-object))
+                [(case (host.check <class> host_object)
+                   (#.Some host_object)
+                   (#try.Success (<method> host_object))
                    #.None)]
 
                 [gnu/math/IntNum gnu/math/IntNum::longValue]
@@ -266,90 +301,163 @@
                 [program/VariantValue program/VariantValue::getValue]
                 [program/TupleValue program/TupleValue::getValue]
                 ))
-          (case (host.check gnu/lists/Pair host-object)
-            (#.Some host-object)
-            (read-variant read host-object)
+          (case (host.check gnu/lists/Pair host_object)
+            (#.Some host_object)
+            (read_variant read host_object)
             #.None)
-          (case (host.check gnu/lists/FVector host-object)
-            (#.Some host-object)
-            (read-tuple read (:coerce (gnu/lists/FVector java/lang/Object) host-object))
+          (case (host.check gnu/lists/FVector host_object)
+            (#.Some host_object)
+            (read_tuple read (:coerce (gnu/lists/FVector java/lang/Object) host_object))
             #.None)
           ## else
-          (exception.throw ..unknown-kind-of-host-object host-object))))
+          (exception.throw ..unknown_kind_of_host_object host_object))))
 
-(def: ensure-macro
-  (-> Macro (Maybe gnu/expr/ModuleMethod))
-  (|>> (:coerce java/lang/Object) (host.check gnu/expr/ModuleMethod)))
+(def: ensure_macro
+  (-> Macro (Maybe gnu/mapping/Procedure))
+  (|>> (:coerce java/lang/Object) (host.check gnu/mapping/Procedure)))
 
 (def: (expander macro inputs lux)
   Expander
-  (case (ensure-macro macro)
+  (case (ensure_macro macro)
     (#.Some macro)
-    (case (gnu/expr/ModuleMethod::apply2 (lux-value (:coerce java/lang/Object inputs))
-                                         (lux-value (:coerce java/lang/Object lux))
+    (case (gnu/mapping/Procedure::apply2 (lux_value (:coerce java/lang/Object inputs))
+                                         (lux_value (:coerce java/lang/Object lux))
                                          macro)
-      (#error.Success output)
+      (#try.Success output)
       (|> output
           ..read
-          (:coerce (Error (Error [Lux (List Code)]))))
+          (:coerce (Try (Try [Lux (List Code)]))))
 
-      (#error.Failure error)
-      (#error.Failure error))
+      (#try.Failure error)
+      (#try.Failure error))
 
     #.None
-    (exception.throw ..cannot-apply-a-non-function (:coerce java/lang/Object macro)))
+    (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro)))
   )
 
 (def: separator "$")
 
-(type: Host
-  (generation.Host _.Expression _.Expression))
-
 (def: host
-  (IO Host)
+  (IO (Host _.Expression _.Expression))
   (io (let [interpreter (kawa/standard/Scheme::getR7rsInstance)
-            evaluate! (function (evaluate! alias input)
-                        (do error.monad
-                          [output (gnu/expr/Language::eval (_.code input) interpreter)]
-                          (read output)))]
-        (: Host
+            run! (: (-> (_.Code Any) (Try Any))
+                    (function (_ input)
+                      (do try.monad
+                        [output (gnu/expr/Language::eval (_.code input) interpreter)]
+                        (read output))))]
+        (: (Host _.Expression _.Expression)
            (structure
-            (def: evaluate! evaluate!)
-            (def: (execute! alias input)
+            (def: (evaluate! context code)
+              (run! code))
+            
+            (def: (execute! input)
               (gnu/expr/Language::eval (_.code input) interpreter))
-            (def: (define! [module name] input)
-              (let [global (format (text.replace-all .module-separator ..separator module)
-                                   ..separator (name.normalize name)
-                                   "___" (%n (text@hash name)))
+            
+            (def: (define! context input)
+              (let [global (reference.artifact context)
                     @global (_.var global)]
-                (do error.monad
-                  [#let [definition (_.define-constant @global input)]
+                (do try.monad
+                  [#let [definition (_.define_constant @global input)]
                    _ (gnu/expr/Language::eval (_.code definition) interpreter)
-                   value (evaluate! global @global)]
-                  (wrap [global value definition])))))))))
+                   value (run! @global)]
+                  (wrap [global value definition]))))
+
+            (def: (ingest context content)
+              (|> content (\ encoding.utf8 decode) try.assume (:coerce _.Expression)))
+
+            (def: (re_learn context content)
+              (run! content))
+            
+            (def: (re_load context content)
+              (do try.monad
+                [_ (run! content)]
+                (run! (_.var (reference.artifact context)))))
+            )))))
 
 (def: platform
-  (IO (Platform IO _.Var _.Expression _.Expression))
+  (IO (Platform _.Var _.Expression _.Expression))
   (do io.monad
     [host ..host]
-    (wrap {#platform.&monad io.monad
-           #platform.&file-system file.system
+    (wrap {#platform.&file_system (file.async file.default)
            #platform.host host
            #platform.phase scheme.generate
-           #platform.runtime runtime.generate})))
+           #platform.runtime runtime.generate
+           #platform.write (|>> _.code (\ encoding.utf8 encode))})))
 
-(def: (program program)
-  (-> _.Expression _.Expression)
+(def: (program context program)
+  (Program _.Expression _.Expression)
   (_.apply/2 program
              ## TODO: Figure out how to always get the command-line
              ## arguments.
              ## It appears that it differs between Scheme implementations.
-             (runtime.lux//program-args _.nil)
+             (runtime.lux//program_args _.nil)
              _.nil))
 
-(program: [{service /cli.service}]
-  (/.compiler ..expander
-              ..platform
-              extension.bundle
-              ..program
-              service))
+(for {@.old
+      (def: extender
+        Extender
+        ## TODO: Stop relying on coercions ASAP.
+        (<| (:coerce Extender)
+            (function (@self handler))
+            (:coerce Handler)
+            (function (@self name phase))
+            (:coerce Phase)
+            (function (@self archive parameters))
+            (:coerce Operation)
+            (function (@self state))
+            (:coerce Try)
+            try.assume
+            (:coerce Try)
+            (#try.Failure "YOLO")))
+
+      @.scheme
+      (def: (extender handler)
+        Extender
+        (:assume handler))})
+
+(def: (declare_success! _)
+  (-> Any (Promise Any))
+  (promise.future (\ world/program.default exit +0)))
+
+(def: (then pre post)
+  (-> _.Expression _.Expression _.Expression)
+  (_.manual (format (_.code pre)
+                    text.new_line
+                    (_.code post))))
+
+(def: (scope body)
+  (-> _.Expression _.Expression)
+  (let [@program (_.var "lux_program")]
+    ($_ ..then
+        (_.define_function @program [(list) #.None] body)
+        (_.apply/* (list) @program)
+        )))
+
+(`` (program: [{service /cli.service}]
+      (let [extension ".scm"]
+        (do io.monad
+          [platform ..platform]
+          (exec (do promise.monad
+                  [_ (/.compiler {#/static.host @.scheme
+                                  #/static.host_module_extension extension
+                                  #/static.target (/cli.target service)
+                                  #/static.artifact_extension extension}
+                                 ..expander
+                                 analysis.bundle
+                                 (io.io platform)
+                                 generation.bundle
+                                 extension/bundle.empty
+                                 ..program
+                                 [_.Var _.Expression _.Expression]
+                                 ..extender
+                                 service
+                                 [(packager.package (_.manual "")
+                                                    _.code
+                                                    ..then
+                                                    ..scope)
+                                  (format (/cli.target service)
+                                          (\ file.default separator)
+                                          "program"
+                                          extension)])]
+                  (..declare_success! []))
+            (io.io []))))))