Merge pull request #58 from LuxLang/hierarchy_normalization

Hierarchy normalization

1 files changed, 143 insertions, 0 deletions

diff --git a/stdlib/source/library/lux/target/jvm/loader.lux b/stdlib/source/library/lux/target/jvm/loader.lux
new file mode 100644
index 000000000..8b86321ca
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/loader.lux
@@ -0,0 +1,143 @@
+(.module:
+  [library
+   [lux #*
+    ["@" target]
+    [abstract
+     [monad (#+ do)]]
+    [control
+     ["." try (#+ Try)]
+     ["." exception (#+ exception:)]
+     ["." io (#+ IO)]
+     [concurrency
+      ["." atom (#+ Atom)]]]
+    [data
+     ["." binary (#+ Binary)]
+     ["." text
+      ["%" format (#+ format)]]
+     [collection
+      ["." array]
+      ["." dictionary (#+ Dictionary)]]]
+    ["." ffi (#+ import: object do_to)]]])
+
+(type: #export Library
+  (Atom (Dictionary Text Binary)))
+
+(exception: #export (already_stored {class Text})
+  (exception.report
+   ["Class" class]))
+
+(exception: #export (unknown {class Text} {known_classes (List Text)})
+  (exception.report
+   ["Class" class]
+   ["Known classes" (exception.enumerate (|>>) known_classes)]))
+
+(exception: #export (cannot_define {class Text} {error Text})
+  (exception.report
+   ["Class" class]
+   ["Error" error]))
+
+(import: java/lang/Object
+  ["#::."
+   (getClass [] (java/lang/Class java/lang/Object))])
+
+(import: java/lang/String)
+
+(import: java/lang/reflect/Method
+  ["#::."
+   (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)])
+
+(import: (java/lang/Class a)
+  ["#::."
+   (getDeclaredMethod [java/lang/String [(java/lang/Class [? < java/lang/Object])]] java/lang/reflect/Method)])
+
+(import: java/lang/Integer
+  ["#::."
+   (#static TYPE (java/lang/Class java/lang/Integer))])
+
+(import: java/lang/reflect/AccessibleObject
+  ["#::."
+   (setAccessible [boolean] void)])
+
+(import: java/lang/ClassLoader
+  ["#::."
+   (loadClass [java/lang/String]
+              #io #try (java/lang/Class java/lang/Object))])
+
+(with_expansions [<elemT> (as_is (java/lang/Class java/lang/Object))]
+  (def: java/lang/ClassLoader::defineClass
+    java/lang/reflect/Method
+    (let [signature (|> (ffi.array <elemT> 4)
+                        (ffi.array_write 0 (:as <elemT>
+                                                (ffi.class_for java/lang/String)))
+                        (ffi.array_write 1 (java/lang/Object::getClass (ffi.array byte 0)))
+                        (ffi.array_write 2 (:as <elemT>
+                                                (java/lang/Integer::TYPE)))
+                        (ffi.array_write 3 (:as <elemT>
+                                                (java/lang/Integer::TYPE))))]
+      (do_to (java/lang/Class::getDeclaredMethod "defineClass"
+                                                 signature
+                                                 (ffi.class_for java/lang/ClassLoader))
+        (java/lang/reflect/AccessibleObject::setAccessible true)))))
+
+(def: #export (define class_name bytecode loader)
+  (-> Text Binary java/lang/ClassLoader (Try java/lang/Object))
+  (let [signature (array.from_list (list (:as java/lang/Object
+                                              class_name)
+                                         (:as java/lang/Object
+                                              bytecode)
+                                         (:as java/lang/Object
+                                              (|> 0
+                                                  (:as (primitive "java.lang.Long"))
+                                                  ffi.long_to_int))
+                                         (:as java/lang/Object
+                                              (|> bytecode
+                                                  binary.size
+                                                  (:as (primitive "java.lang.Long"))
+                                                  ffi.long_to_int))))]
+    (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass)))
+
+(def: #export (new_library _)
+  (-> Any Library)
+  (atom.atom (dictionary.new text.hash)))
+
+(def: #export (memory library)
+  (-> Library java/lang/ClassLoader)
+  (with_expansions [<cast> (for {@.old
+                                 (<|)
+                                 
+                                 @.jvm
+                                 "jvm object cast"})]
+    (<| <cast>
+        (object [] java/lang/ClassLoader []
+          []
+          (java/lang/ClassLoader (findClass self {class_name java/lang/String})
+                                 (java/lang/Class [? < java/lang/Object])
+                                 #throws [java/lang/ClassNotFoundException]
+                                 (let [class_name (:as Text class_name)
+                                       classes (|> library atom.read io.run)]
+                                   (case (dictionary.get class_name classes)
+                                     (#.Some bytecode)
+                                     (case (..define class_name bytecode (<| <cast> self))
+                                       (#try.Success class)
+                                       (:assume class)
+
+                                       (#try.Failure error)
+                                       (error! (exception.construct ..cannot_define [class_name error])))
+
+                                     #.None
+                                     (error! (exception.construct ..unknown [class_name (dictionary.keys classes)])))))))))
+
+(def: #export (store name bytecode library)
+  (-> Text Binary Library (IO (Try Any)))
+  (do {! io.monad}
+    [library' (atom.read library)]
+    (if (dictionary.key? library' name)
+      (wrap (exception.throw ..already_stored name))
+      (do !
+        [_ (atom.update (dictionary.put name bytecode) library)]
+        (wrap (#try.Success []))))))
+
+(def: #export (load name loader)
+  (-> Text java/lang/ClassLoader
+      (IO (Try (java/lang/Class java/lang/Object))))
+  (java/lang/ClassLoader::loadClass name loader))