ClassLoader machinery.

2 files changed, 155 insertions, 109 deletions

diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux
index 47fbbefcf..9a6eb25ed 100644
--- a/new-luxc/source/luxc/lang/translation/jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm.lux
@@ -14,7 +14,9 @@
      ["." array]
      [list ("list/." Functor<List>)]
      ["." dictionary (#+ Dictionary)]]]
-   ["." host (#+ import: do-to object)]
+   ["." host (#+ import: do-to object)
+    [jvm
+     ["." loader]]]
    ["." io (#+ IO io)]
    [world
     [binary (#+ Binary)]]
@@ -33,99 +35,19 @@
 
 (import: org/objectweb/asm/Label)
 
-(import: java/lang/reflect/AccessibleObject
-  (setAccessible [boolean] void))
-
 (import: java/lang/reflect/Field
   (get [#? Object] #try #? Object))
 
-(import: java/lang/reflect/Method
-  (invoke [Object (Array Object)] #try Object))
-
 (import: (java/lang/Class a)
-  (getField [String] #try Field)
-  (getDeclaredMethod [String (Array (Class Object))] #try Method))
+  (getField [String] #try Field))
 
 (import: java/lang/Object
   (getClass [] (Class Object)))
 
-(import: java/lang/Integer
-  (#static TYPE (Class Integer)))
-
-(import: java/lang/ClassLoader
-  (loadClass [String] #try (Class Object)))
-
-(def: ClassLoader::defineClass
-  Method
-  (case (Class::getDeclaredMethod "defineClass"
-                                  (|> (host.array (Class Object) 4)
-                                      (host.array-write 0 (:coerce (Class Object) (host.class-for String)))
-                                      (host.array-write 1 (Object::getClass (host.array byte 0)))
-                                      (host.array-write 2 (:coerce (Class Object) (Integer::TYPE)))
-                                      (host.array-write 3 (:coerce (Class Object) (Integer::TYPE))))
-                                  (host.class-for java/lang/ClassLoader))
-    (#error.Success method)
-    (do-to method
-      (AccessibleObject::setAccessible #1))
-
-    (#error.Error error)
-    (error! error)))
+(import: java/lang/ClassLoader)
 
 (type: #export ByteCode Binary)
 
-(def: (define-class class-name bytecode loader)
-  (-> Text ByteCode ClassLoader (Error Object))
-  (Method::invoke loader
-                  (array.from-list (list (:coerce Object class-name)
-                                         (:coerce Object bytecode)
-                                         (:coerce Object (host.long-to-int +0))
-                                         (:coerce Object (host.long-to-int (.int (host.array-length bytecode))))))
-                  ClassLoader::defineClass))
-
-(type: Store (Atom (Dictionary Text ByteCode)))
-
-(exception: #export (class-already-stored {class Text})
-  (ex.report ["Class" class]))
-
-(exception: #export (unknown-class {class Text} {known-classes (List Text)})
-  (ex.report ["Class" class]
-             ["Known Classes" (|> known-classes
-                                  (list/map (|>> (format "\n\t")))
-                                  (text.join-with ""))]))
-
-(exception: #export (cannot-define-class {class Text} {error Text})
-  (ex.report ["Class" class]
-             ["Error" error]))
-
-(def: (memory-class-loader store)
-  (-> Store ClassLoader)
-  (object [] ClassLoader []
-    []
-    (ClassLoader (findClass {class-name String}) Class
-                 (let [classes (|> store atom.read io.run)]
-                   (case (dictionary.get class-name classes)
-                     (#.Some bytecode)
-                     (case (define-class class-name bytecode (:coerce ClassLoader _jvm_this))
-                       (#error.Success class)
-                       (:assume class)
-
-                       (#error.Error error)
-                       (error! (ex.construct cannot-define-class [class-name error])))
-
-                     #.None
-                     (error! (ex.construct unknown-class [class-name (dictionary.keys classes)])))))))
-
-(def: (store! name bytecode store)
-  (-> Text ByteCode Store (Error Any))
-  (if (|> store atom.read io.run (dictionary.contains? name))
-    (ex.throw class-already-stored name)
-    (exec (io.run (atom.update (dictionary.put name bytecode) store))
-      (#error.Success []))))
-
-(def: (load! name loader)
-  (-> Text ClassLoader (Error (Class Object)))
-  (ClassLoader::loadClass name loader))
-
 (def: #export value-field Text "_value")
 (def: #export $Object jvm.Type (type.class "java.lang.Object" (list)))
 
@@ -165,30 +87,30 @@
 
 (def: (evaluate! store loader eval-class valueI)
   (-> Store ClassLoader Text Inst (Error Any))
-  (do error.Monad<Error>
-    [#let [bytecode-name (text.replace-all class-path-separator module-separator eval-class)
-           bytecode (def.class #jvm.V1_6
-                               #jvm.Public jvm.noneC
-                               bytecode-name
-                               (list) ["java.lang.Object" (list)]
-                               (list)
-                               (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF)
-                                               ..value-field ..$Object)
-                                    (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM)
-                                                "<clinit>"
-                                                (type.method (list) #.None (list))
-                                                (|>> valueI
-                                                     (inst.PUTSTATIC bytecode-name ..value-field ..$Object)
-                                                     inst.RETURN))))]
-     _ (..store! eval-class bytecode store)
-     class (..load! eval-class loader)]
-    (class-value eval-class class)))
+  (let [bytecode-name (text.replace-all class-path-separator module-separator eval-class)
+        bytecode (def.class #jvm.V1_6
+                            #jvm.Public jvm.noneC
+                            bytecode-name
+                            (list) ["java.lang.Object" (list)]
+                            (list)
+                            (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF)
+                                            ..value-field ..$Object)
+                                 (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM)
+                                             "<clinit>"
+                                             (type.method (list) #.None (list))
+                                             (|>> valueI
+                                                  (inst.PUTSTATIC bytecode-name ..value-field ..$Object)
+                                                  inst.RETURN))))]
+    (io.run (do (error.ErrorT io.Monad<IO>)
+              [_ (loader.store eval-class bytecode store)
+               class (loader.load eval-class loader)]
+              (:: io.Monad<IO> wrap (class-value eval-class class))))))
 
 (def: (execute! store loader temp-label [class-name class-bytecode])
   (-> Store ClassLoader Text Definition (Error Any))
-  (do error.Monad<Error>
-    [_ (..store! class-name class-bytecode store)]
-    (..load! class-name loader)))
+  (io.run (do (error.ErrorT io.Monad<IO>)
+            [_ (loader.store class-name class-bytecode store)]
+            (loader.load class-name loader))))
 
 (def: (define! store loader [module name] valueI)
   (-> Store ClassLoader Name Inst (Error [Text Any]))
@@ -201,15 +123,15 @@
 
 (def: #export init
   (IO Host)
-  (io (let [store (: Store (atom (dictionary.new text.Hash<Text>)))
-            loader (memory-class-loader store)]
+  (io (let [library (loader.new-library [])
+            loader (loader.memory library)]
         (: Host
            (structure
             (def: (evaluate! temp-label valueI)
               (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))]
-                (..evaluate! store loader eval-class valueI)))
-            (def: execute! (..execute! store loader))
-            (def: define! (..define! store loader)))))))
+                (..evaluate! library loader eval-class valueI)))
+            (def: execute! (..execute! library loader))
+            (def: define! (..define! library loader)))))))
 
 (def: #export runtime-class "LuxRuntime")
 (def: #export function-class "LuxFunction")
diff --git a/stdlib/source/lux/host/jvm/loader.lux b/stdlib/source/lux/host/jvm/loader.lux
new file mode 100644
index 000000000..b4d5089d4
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/loader.lux
@@ -0,0 +1,124 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]
+    [concurrency
+     ["." atom (#+ Atom)]]]
+   [data
+    ["." error (#+ Error)]
+    ["." text
+     format]
+    [collection
+     ["." array]
+     ["." list ("list/." Functor<List>)]
+     ["." dictionary (#+ Dictionary)]]]
+   ["." io (#+ IO)]
+   [world
+    ["." binary (#+ Binary)]]
+   ["." host (#+ import: object do-to)]])
+
+(type: #export Library
+  (Atom (Dictionary Text Binary)))
+
+(exception: #export (already-stored {class Text})
+  (ex.report ["Class" class]))
+
+(exception: #export (unknown {class Text} {known-classes (List Text)})
+  (ex.report ["Class" class]
+             ["Known classes" (|> known-classes
+                                  (list/map (|>> (format text.new-line text.tab)))
+                                  (text.join-with ""))]))
+
+(exception: #export (cannot-define {class Text} {error Text})
+  (ex.report ["Class" class]
+             ["Error" error]))
+
+(import: #long java/lang/Object
+  (getClass [] (java/lang/Class java/lang/Object)))
+
+(import: #long java/lang/String)
+
+(import: #long java/lang/reflect/Method
+  (invoke [java/lang/Object (Array java/lang/Object)]
+          #try java/lang/Object))
+
+(import: #long (java/lang/Class a)
+  (getDeclaredMethod [java/lang/String (Array (java/lang/Class java/lang/Object))]
+                     #try java/lang/reflect/Method))
+
+(import: #long java/lang/Integer
+  (#static TYPE (java/lang/Class java/lang/Integer)))
+
+(import: #long java/lang/reflect/AccessibleObject
+  (setAccessible [boolean] void))
+
+(import: #long java/lang/ClassLoader
+  (loadClass [java/lang/String]
+             #io #try (java/lang/Class java/lang/Object)))
+
+(def: java/lang/ClassLoader::defineClass
+  java/lang/reflect/Method
+  (let [signature (|> (host.array (java/lang/Class java/lang/Object) 4)
+                      (host.array-write 0 (:coerce (java/lang/Class java/lang/Object)
+                                                   (host.class-for java/lang/String)))
+                      (host.array-write 1 (java/lang/Object::getClass (host.array byte 0)))
+                      (host.array-write 2 (:coerce (java/lang/Class java/lang/Object)
+                                                   (java/lang/Integer::TYPE)))
+                      (host.array-write 3 (:coerce (java/lang/Class java/lang/Object)
+                                                   (java/lang/Integer::TYPE))))]
+    (do-to (error.assume
+            (java/lang/Class::getDeclaredMethod "defineClass"
+                                                signature
+                                                (host.class-for java/lang/ClassLoader)))
+      (java/lang/reflect/AccessibleObject::setAccessible true))))
+
+(def: #export (define class-name bytecode loader)
+  (-> Text Binary java/lang/ClassLoader (Error java/lang/Object))
+  (let [signature (array.from-list (list (:coerce java/lang/Object
+                                                  class-name)
+                                         (:coerce java/lang/Object
+                                                  bytecode)
+                                         (:coerce java/lang/Object
+                                                  (host.long-to-int +0))
+                                         (:coerce java/lang/Object
+                                                  (host.long-to-int (.int (binary.size bytecode))))))]
+    (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass)))
+
+(def: #export (new-library _)
+  (-> Any Library)
+  (atom.atom (dictionary.new text.Hash<Text>)))
+
+(def: #export (memory library)
+  (-> Library java/lang/ClassLoader)
+  (object [] java/lang/ClassLoader []
+    []
+    (java/lang/ClassLoader (findClass {class-name java/lang/String}) java/lang/Class
+                           (let [classes (|> library atom.read io.run)]
+                             (case (dictionary.get class-name classes)
+                               (#.Some bytecode)
+                               (case (|> _jvm_this
+                                         (..define class-name bytecode))
+                                 (#error.Success class)
+                                 (:assume class)
+
+                                 (#error.Failure error)
+                                 (error! (ex.construct ..cannot-define [class-name error])))
+
+                               #.None
+                               (error! (ex.construct ..unknown [class-name (dictionary.keys classes)])))))))
+
+(def: #export (store name bytecode library)
+  (-> Text Binary Library (IO (Error Any)))
+  (do io.Monad<IO>
+    [library' (atom.read library)]
+    (if (dictionary.contains? name library')
+      (wrap (ex.throw ..already-stored name))
+      (do @
+        [_ (atom.update (dictionary.put name bytecode) library)]
+        (wrap (#error.Success []))))))
+
+(def: #export (load name loader)
+  (-> Text java/lang/ClassLoader
+      (IO (Error (java/lang/Class java/lang/Object))))
+  (java/lang/ClassLoader::loadClass name loader))