- WIP: Wiring everything to get the compiler to work fully.

- Fixed a bug when combining field/method/class modifiers.

8 files changed, 254 insertions, 121 deletions

diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux
index 107b2f3f9..f64ca333e 100644
--- a/new-luxc/source/luxc/generator.lux
+++ b/new-luxc/source/luxc/generator.lux
@@ -1,52 +1,83 @@
 (;module:
   lux
-  (lux (control monad)
-       (concurrency ["A" atom]
-                    ["P" promise])
+  (lux (control [monad #+ do])
+       (concurrency ["T" task])
        (data ["e" error]
-             [text "T/" Hash<Text>]
+             [text "text/" Hash<Text>]
              text/format
-             (coll ["D" dict]
-                   [array]))
-       [meta #+ Monad<Meta>]
+             (coll [dict]))
+       [meta]
        [host]
-       [io])
+       [io]
+       (world [file #+ File]))
   (luxc ["&" base]
         ["&;" io]
         ["&;" module]
         ["&;" parser]
         ["&;" host]
-        (compiler ["&&;" runtime]
-                  ["&&;" statement]
-                  ["&&;" common])
+        ["&;" analyser]
+        ["&;" analyser/common]
+        ["&;" synthesizer]
+        ["&;" eval]
+        (generator ["&&;" runtime]
+                   ["&&;" statement]
+                   ["&&;" common]
+                   ["&&;" expr]
+                   ["&&;" eval])
         ))
 
-(def: (compile ast)
+(def: analyse
+  (&;Analyser)
+  (&analyser;analyser &eval;eval))
+
+(def: (generate code)
   (-> Code (Meta Unit))
-  (case ast
-    (^ [_ (#;Form (list [_ (#;Symbol ["" "_lux_def"])]
+  (case code
+    (^ [_ (#;Form (list [_ (#;Text "lux def")]
                         [_ (#;Symbol ["" def-name])]
-                        def-value
-                        def-meta))])
-    (&&statement;compile-def def-name def-value def-meta)
-
-    (^ [_ (#;Form (list [_ (#;Symbol ["" "_lux_program"])]
-                        [_ (#;Symbol ["" prog-args])]
-                        prog-body))])
-    (&&statement;compile-program prog-args prog-body)
+                        valueC
+                        metaC))])
+    (do meta;Monad<Meta>
+      [[_ metaA] (&;with-scope
+                   (&;with-expected-type Code
+                     (analyse metaC)))
+       metaI (&&expr;generate (&synthesizer;synthesize metaA))
+       metaV (&&eval;eval metaI)
+       [_ valueT valueA] (&;with-scope
+                           (if (meta;type? (:! Code metaV))
+                             (&;with-expected-type Type
+                               (do @
+                                 [valueA (analyse valueC)]
+                                 (wrap [Type valueA])))
+                             (&analyser/common;with-unknown-type
+                               (analyse valueC))))
+       valueI (&&expr;generate (&synthesizer;synthesize valueA))
+       _ (&;with-scope
+           (&&statement;generate-def def-name valueT valueI metaI (:! Code metaV)))]
+      (wrap []))
+
+    (^ [_ (#;Form (list [_ (#;Text "lux program")]
+                        [_ (#;Symbol ["" program-args])]
+                        programC))])
+    (do meta;Monad<Meta>
+      [[_ programA] (&;with-scope
+                      (&;with-expected-type (type (io;IO Unit))
+                        (analyse programC)))
+       programI (&&expr;generate (&synthesizer;synthesize programA))]
+      (&&statement;generate-program program-args programI))
 
     _
-    (&;fail (format "Unrecognized statement: " (%code ast)))))
+    (&;fail (format "Unrecognized statement: " (%code code)))))
 
 (def: (exhaust action)
   (All [a] (-> (Meta a) (Meta Unit)))
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [result action]
     (exhaust action)))
 
 (def: (ensure-new-module! file-hash module-name)
   (-> Nat Text (Meta Unit))
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [module-exists? (meta;module-exists? module-name)
      _ (: (Meta Unit)
           (if module-exists?
@@ -59,10 +90,10 @@
 
 (def: (with-active-compilation [module-name file-name source-code] action)
   (All [a] (-> [Text Text Text] (Meta a) (Meta a)))
-  (do Monad<Meta>
-    [_ (ensure-new-module! (T/hash source-code) module-name)
+  (do meta;Monad<Meta>
+    [_ (ensure-new-module! (text/hash source-code) module-name)
      #let [init-cursor [file-name +0 +0]]
-     output (&;with-source-code [init-cursor source-code]
+     output (&;with-source-code [init-cursor +0 source-code]
               action)
      _ (&module;flag-compiled! module-name)]
     (wrap output)))
@@ -78,37 +109,35 @@
       (#e;Success [(set@ #;source source' compiler)
                    output]))))
 
-(def: (compile-module source-dirs module-name compiler)
-  (-> (List &;Path) Text Compiler (P;Promise (e;Error Compiler)))
-  (do P;Monad<Promise>
-    [?input (&io;read-module source-dirs module-name)]
-    (case ?input
-      (#e;Success [file-name file-content])
-      (let [compilation (do Monad<Meta>
-                          [_ (with-active-compilation [module-name
-                                                       file-name
-                                                       file-content]
-                               (exhaust
-                                (do @
-                                  [ast parse]
-                                  (compile ast))))]
-                          (wrap [])
-                          ## (&module;generate-descriptor module-name)
-                          )]
-        (case (meta;run' compiler compilation)
-          (#e;Success [compiler module-descriptor])
-          (do @
-            [## _ (&io;write-module module-name module-descriptor)
-             ]
-            (wrap (#e;Success compiler)))
-          
-          (#e;Error error)
-          (wrap (#e;Error error))))
-
+(def: (generate-module source-dirs module-name target-dir compiler)
+  (-> (List File) Text File Compiler (T;Task Compiler))
+  (do T;Monad<Task>
+    [_ (&io;prepare-module target-dir module-name)
+     [file-name file-content] (&io;read-module source-dirs module-name)]
+    (case (meta;run' compiler
+                     (do meta;Monad<Meta>
+                       [[artifacts _] (&&common;with-artifacts
+                                        (with-active-compilation [module-name
+                                                                  file-name
+                                                                  file-content]
+                                          (exhaust
+                                           (do @
+                                             [code parse]
+                                             (generate code)))))]
+                       (wrap artifacts)
+                       ## (&module;generate-descriptor module-name)
+                       ))
+      (#e;Success [compiler artifacts ## module-descriptor
+                   ])
+      (do @
+        [## _ (&io;write-module module-name module-descriptor)
+         _ (monad;map @ (function [[class-name class-bytecode]]
+                          (&io;write-file target-dir class-name class-bytecode))
+                      (dict;entries artifacts))]
+        (wrap compiler))
+      
       (#e;Error error)
-      (wrap (#e;Error error)))))
-
-(host;import org.objectweb.asm.MethodVisitor)
+      (T;fail error))))
 
 (def: init-cursor Cursor ["" +0 +0])
 
@@ -127,7 +156,7 @@
 (def: #export (init-compiler host)
   (-> &&common;Host Compiler)
   {#;info            init-info
-   #;source          [init-cursor ""]
+   #;source          [init-cursor +0 ""]
    #;cursor          init-cursor
    #;modules         (list)
    #;scopes          (list)
@@ -137,23 +166,21 @@
    #;scope-type-vars (list)
    #;host            (:! Void host)})
 
-(def: (or-crash! action)
-  (All [a] (-> (P;Promise (e;Error a)) (P;Promise a)))
-  (do P;Monad<Promise>
-    [?output action]
-    (case ?output
-      (#e;Error error)
-      (error! error)
-
-      (#e;Success output)
-      (wrap output))))
-
-(def: #export (compile-program program target sources)
-  (-> &;Path &;Path (List &;Path) (P;Promise Unit))
-  (do P;Monad<Promise>
-    [#let [compiler (init-compiler (&host;init-host []))]
-     compiler (or-crash! (&&runtime;compile-runtime compiler))
-     compiler (or-crash! (compile-module sources prelude compiler))
-     compiler (or-crash! (compile-module sources program compiler))
+(def: #export (generate-program program target sources)
+  (-> Text File (List File) (T;Task Unit))
+  (do T;Monad<Task>
+    [compiler (|> (case (&&runtime;generate (init-compiler (io;run &host;init-host)))
+                    (#e;Error error)
+                    (T;fail error)
+
+                    (#e;Success [compiler [runtime-bc function-bc]])
+                    (do @
+                      [_ (&io;prepare-target target)
+                       _ (&io;write-file target &&runtime;runtime-class runtime-bc)
+                       _ (&io;write-file target &&runtime;function-class function-bc)]
+                      (wrap compiler)))
+                  (: (T;Task Compiler))
+                  (:: @ map (generate-module sources prelude target)) (:: @ join)
+                  (:: @ map (generate-module sources program target)) (:: @ join))
      #let [_ (log! "Compilation complete!")]]
     (wrap [])))
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
index 150e68e4f..4439ae51d 100644
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/common.jvm.lux
@@ -4,8 +4,11 @@
        [io]
        (concurrency ["A" atom])
        (data ["e" error]
-             (coll ["d" dict]))
-       [host])
+             [text]
+             text/format
+             (coll [dict #+ Dict]))
+       [host]
+       (world [blob #+ Blob]))
   (luxc (generator (host ["$" jvm]
                          (jvm ["$t" type]
                               ["$d" def]
@@ -23,16 +26,52 @@
 
 (type: #export Bytecode (host;type (Array byte)))
 
-(type: #export Class-Store (A;Atom (d;Dict Text Bytecode)))
+(type: #export Class-Store (A;Atom (Dict Text Bytecode)))
+
+(type: #export Artifacts (Dict Text Blob))
 
 (type: #export Host
   {#loader ClassLoader
    #store Class-Store
-   #function-class (Maybe Text)})
+   #function-class (Maybe Text)
+   #artifacts Artifacts})
 
 (exception: Unknown-Class)
 (exception: Class-Already-Stored)
 (exception: No-Function-Being-Compiled)
+(exception: Cannot-Overwrite-Artifact)
+
+(def: #export (with-artifacts action)
+  (All [a] (-> (Meta a) (Meta [Artifacts a])))
+  (;function [compiler]
+    (case (action (update@ #;host
+                           (|>. (:! Host)
+                                (set@ #artifacts (dict;new text;Hash<Text>))
+                                (:! Void))
+                           compiler))
+      (#e;Success [compiler' output])
+      (#e;Success [(update@ #;host
+                            (|>. (:! Host)
+                                 (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts)))
+                                 (:! Void))
+                            compiler')
+                   [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts))
+                    output]])
+      
+      (#e;Error error)
+      (#e;Error error))))
+
+(def: #export (record-artifact name content)
+  (-> Text Blob (Meta Unit))
+  (;function [compiler]
+    (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name))
+      (ex;throw Cannot-Overwrite-Artifact name)
+      (#e;Success [(update@ #;host
+                            (|>. (:! Host)
+                                 (update@ #artifacts (dict;put name content))
+                                 (:! Void))
+                            compiler)
+                   []]))))
 
 (def: #export (store-class name byte-code)
   (-> Text Bytecode (Meta Unit))
@@ -40,9 +79,9 @@
     (let [store (|> (get@ #;host compiler)
                     (:! Host)
                     (get@ #store))]
-      (if (d;contains? name (|> store A;get io;run))
+      (if (dict;contains? name (|> store A;get io;run))
         (ex;throw Class-Already-Stored name)
-        (#e;Success [compiler (io;run (A;update (d;put name byte-code) store))])
+        (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))])
         ))))
 
 (def: #export (load-class name)
@@ -50,7 +89,7 @@
   (;function [compiler]
     (let [host (:! Host (get@ #;host compiler))
           store (|> host (get@ #store) A;get io;run)]
-      (if (d;contains? name store)
+      (if (dict;contains? name store)
         (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
         (ex;throw Unknown-Class name)))))
 
@@ -87,3 +126,6 @@
         (#e;Success [compiler function-class])))))
 
 (def: #export bytecode-version Int Opcodes.V1_6)
+
+(def: #export value-field Text "_value")
+(def: #export $Object $;Type ($t;class "java.lang.Object" (list)))
diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux
index 20c02af4c..842199a47 100644
--- a/new-luxc/source/luxc/generator/eval.jvm.lux
+++ b/new-luxc/source/luxc/generator/eval.jvm.lux
@@ -56,9 +56,6 @@
   (visitMethod [int String String String (Array String)] MethodVisitor)
   (toByteArray [] (Array byte)))
 
-(def: eval-field Text "_value")
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
 (def: #export (eval valueI)
   (-> $;Inst (Meta Top))
   (do Monad<Meta>
@@ -70,17 +67,17 @@
                                             (host;null)
                                             "java/lang/Object"
                                             (host;null)]))
-                      ($d;field #$;Public $;staticF
-                                eval-field $Object)
+                      ($d;field #$;Public ($_ $;++F $;finalF $;staticF)
+                                &common;value-field &common;$Object)
                       ($d;method #$;Public ($_ $;++M $;staticM $;strictM)
                                  "<clinit>"
                                  ($t;method (list) #;None (list))
                                  (|>. valueI
-                                      ($i;PUTSTATIC class-name eval-field $Object)
+                                      ($i;PUTSTATIC class-name &common;value-field &common;$Object)
                                       $i;RETURN)))
            bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
      _ (&common;store-class class-name bytecode)
      class (&common;load-class class-name)]
     (wrap (|> class
-              (Class.getField [eval-field])
+              (Class.getField [&common;value-field])
               (Field.get (host;null))))))
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index c7fdcf2af..116c29fb5 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -44,6 +44,9 @@
       (&reference;generate-captured var)
       (&reference;generate-variable var))
 
+    (#ls;Definition definition)
+    (&reference;generate-definition definition)
+
     (#ls;Function arity env body)
     (&function;generate-function generate env arity body)
 
@@ -54,7 +57,8 @@
     (&procedure;generate-procedure generate name args)
 
     _
-    (meta;fail "Unrecognized synthesis.")))
+    (meta;fail "Unrecognized synthesis.")
+    ))
 
 ## (def: #export (eval type code)
 ##   (-> Type Code (Meta Top))
diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux
index c985efc9a..24d4a9ea9 100644
--- a/new-luxc/source/luxc/generator/host/jvm.lux
+++ b/new-luxc/source/luxc/generator/host/jvm.lux
@@ -109,8 +109,8 @@
                  (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right))
                       (-> (~ g!type) (~ g!type) (~ g!type))
                       (~ (code;record (list/map (function [tag]
-                                                  [tag (` (and (get@ (~ tag) (~ g!_left))
-                                                               (get@ (~ tag) (~ g!_right))))])
+                                                  [tag (` (or (get@ (~ tag) (~ g!_left))
+                                                              (get@ (~ tag) (~ g!_right))))])
                                                 g!tags+)))))
 
                  g!options+))))
diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux
index 063994bac..0e77b1819 100644
--- a/new-luxc/source/luxc/generator/reference.jvm.lux
+++ b/new-luxc/source/luxc/generator/reference.jvm.lux
@@ -3,15 +3,14 @@
   (lux (control [monad #+ do])
        (data text/format)
        [meta "meta/" Monad<Meta>])
-  (luxc (lang ["ls" synthesis])
+  (luxc ["&" base]
+        (lang ["ls" synthesis])
         (generator [";G" common]
                    [";G" function]
                    (host ["$" jvm]
                          (jvm ["$t" type]
                               ["$i" inst])))))
 
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
 (def: #export (generate-captured variable)
   (-> ls;Variable (Meta $;Inst))
   (do meta;Monad<Meta>
@@ -19,8 +18,13 @@
     (wrap (|>. ($i;ALOAD +0)
                ($i;GETFIELD function-class
                             (|> variable i.inc (i.* -1) int-to-nat functionG;captured)
-                            $Object)))))
+                            commonG;$Object)))))
 
 (def: #export (generate-variable variable)
   (-> ls;Variable (Meta $;Inst))
   (meta/wrap ($i;ALOAD (int-to-nat variable))))
+
+(def: #export (generate-definition [def-module def-name])
+  (-> Ident (Meta $;Inst))
+  (let [bytecode-name (format def-module "/" (&;normalize-name def-name))]
+    (meta/wrap ($i;GETSTATIC bytecode-name commonG;value-field commonG;$Object))))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 32e792638..66dd43019 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -504,8 +504,8 @@
     (wrap bytecode)))
 
 (def: #export generate
-  (Meta Unit)
+  (Meta [&common;Bytecode &common;Bytecode])
   (do Monad<Meta>
-    [_ generate-runtime
-     _ generate-function]
-    (wrap [])))
+    [runtime-bc generate-runtime
+     function-bc generate-function]
+    (wrap [runtime-bc function-bc])))
diff --git a/new-luxc/source/luxc/generator/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux
index ed66f3ecb..830935dda 100644
--- a/new-luxc/source/luxc/generator/statement.jvm.lux
+++ b/new-luxc/source/luxc/generator/statement.jvm.lux
@@ -1,25 +1,84 @@
 (;module:
   lux
-  (lux (control monad)
-       [io #- run]
-       (data [text "T/" Eq<Text>]
-             text/format)
-       [meta #+ Monad<Meta>])
+  (lux (control monad
+                ["ex" exception #+ exception:])
+       (concurrency ["T" task])
+       (data ["e" error]
+             [maybe]
+             [text "text/" Monoid<Text>]
+             text/format
+             (coll [list "list/" Functor<List> Fold<List>]))
+       [meta]
+       [host])
   (luxc ["&" base]
-        ["&;" module]
         ["&;" scope]
-        (compiler ["&;" expr])))
+        ["&;" module]
+        ["&;" io]
+        (generator ["&;" expr]
+                   ["&;" eval]
+                   ["&;" common]
+                   (host ["$" jvm]
+                         (jvm ["$t" type]
+                              ["$d" def]
+                              ["$i" inst])))))
+
+(exception: #export Invalid-Definition-Value)
+
+(host;import java.lang.Object
+  (toString [] String))
+
+(host;import java.lang.reflect.Field
+  (get [#? Object] #try #? Object))
+
+(host;import (java.lang.Class c)
+  (getField [String] #try Field))
+
+(def: #export (generate-def def-name valueT valueI metaI metaV)
+  (-> Text Type $;Inst $;Inst Code (Meta Unit))
+  (do meta;Monad<Meta>
+    [current-module meta;current-module-name
+     #let [def-ident [current-module def-name]
+           normal-name (&;normalize-name def-name)
+           bytecode-name (format current-module "/" normal-name)
+           class-name (format current-module "." normal-name)
+           bytecode ($d;class #$;V1.6
+                              #$;Public $;finalC
+                              bytecode-name
+                              (list) ["java.lang.Object" (list)]
+                              (list)
+                              (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) &common;value-field &common;$Object)
+                                   ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
+                                              (|>. valueI
+                                                   ($i;PUTSTATIC bytecode-name &common;value-field &common;$Object)
+                                                   $i;RETURN))))]
+     _ (&common;store-class class-name bytecode)
+     class (&common;load-class class-name)
+     valueV (: (Meta Top)
+               (case (do e;Monad<Error>
+                       [field (Class.getField [&common;value-field] class)]
+                       (Field.get [#;None] field))
+                 (#e;Success #;None)
+                 (&;throw Invalid-Definition-Value (format current-module ";" def-name))
+                 
+                 (#e;Success (#;Some valueV))
+                 (wrap valueV)
+                 
+                 (#e;Error error)
+                 (&;fail error)))
+     _ (&module;define [current-module def-name] [valueT metaV valueV])
+     _ (if (meta;type? metaV)
+         (case (meta;declared-tags metaV)
+           #;Nil
+           (wrap [])
 
-(def: #export (compile-def def-name def-value def-meta)
-  (-> Text Code Code (Meta Unit))
-  (do Monad<Meta>
-    [=def-value (&expr;compile def-value)
-     =def-meta (&expr;compile def-meta)]
-    (undefined)))
+           tags
+           (&module;declare-tags tags (meta;export? metaV) (:! Type valueV)))
+         (wrap []))
+     #let [_ (log! (format "DEF " current-module ";" def-name))]]
+    (&common;record-artifact bytecode-name bytecode)))
 
-(def: #export (compile-program prog-args prog-body)
-  (-> Text Code (Meta Unit))
-  (do Monad<Meta>
-    [=prog-body (&scope;with-local [prog-args (type (List Text))]
-                  (&expr;compile prog-body))]
-    (undefined)))
+(def: #export (generate-program program-args programI)
+  (-> Text $;Inst (Meta Unit))
+  (do meta;Monad<Meta>
+    []
+    (&;fail "'lux program' is unimplemented.")))