- Expanded the lux/host/jvm library.

2 files changed, 138 insertions, 24 deletions

diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux
index ba29925a7..710bc9a20 100644
--- a/source/lux/host/jvm.lux
+++ b/source/lux/host/jvm.lux
@@ -6,14 +6,17 @@
 (;import lux
          (lux (control (monoid #as m)
                        (functor #as F)
-                       (monad #as M #refer (#only do)))
+                       (monad #as M #refer (#only do seq%)))
               (data (list #refer #all #open ("" List/Functor List/Fold))
                     (number/int #refer #all #open ("i:" Int/Ord))
-                    maybe)
+                    maybe
+                    tuple)
               (meta lux
                     ast
                     syntax)))
 
+(open List/Monad "list:")
+
 ## [Utils]
 ## Parsers
 (def method-decl^
@@ -50,6 +53,11 @@
             body id^]
            (wrap [modifiers name inputs output body]))))
 
+(def opt-arg^
+  (Parser (, Bool Text))
+  (&^ (tag?^ ["" "?"])
+      local-symbol^))
+
 ## [Syntax]
 (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)])
   (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST)
@@ -115,3 +123,113 @@
                           type
                           (repeat dimensions []))))
       (fail "Array must have positive dimension."))))
+
+(defsyntax #export (instance? [class local-symbol^] obj)
+  (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj))))))
+
+(defsyntax #export (locking lock body)
+  (do Lux/Monad
+    [g!lock (gensym "")
+     g!body (gensym "")
+     g!_ (gensym "")]
+    (emit (@list (` (let [(~ g!lock) (~ lock)
+                          (~ g!_) (;_jvm_monitorenter (~ g!lock))
+                          (~ g!body) (~ body)
+                          (~ g!_) (;_jvm_monitorexit (~ g!lock))]
+                      (~ g!body)))))
+    ))
+
+(defsyntax #export (null? obj)
+  (emit (@list (` (;_jvm_null? (~ obj))))))
+
+(def (prepare-args args)
+  (-> (List (, Bool Text)) (Lux (, (List AST) (List AST) (List AST) (List Text))))
+  (do Lux/Monad
+    [vars (seq% Lux/Monad (repeat (size args) (gensym "")))
+     #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST)))
+                            (lambda [[[opt? arg-class] var]]
+                              (if opt?
+                                [(` (Maybe (^ (~ (symbol$ ["" arg-class])))))
+                                 (@list var (` (: (^ (~ (symbol$ ["" arg-class])))
+                                                  (case (~ var)
+                                                    (#;Some (~ var)) (~ var)
+                                                    #;None           ;_jvm_null))))]
+                                [(` (^ (~ (symbol$ ["" arg-class]))))
+                                 (@list)])))
+                         (zip2 args vars))
+           var-types (map first pairings)
+           var-rebinds (map second pairings)
+           arg-classes (map second args)]]
+    (wrap [vars var-types (list:join var-rebinds) arg-classes])))
+
+(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ opt-arg^))])
+  (do Lux/Monad
+    [[vars var-types var-rebinds arg-classes] (prepare-args args)]
+    (case vars
+      (\ (@list))
+      (do Lux/Monad
+        [g!_ (gensym "")]
+        (wrap (@list (` (: (-> (,) (^ (~ (symbol$ ["" class]))))
+                           (lambda [(~ g!_)]
+                             (;_jvm_new (~ (text$ class)) [] [])))))))
+
+      _
+      (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))))
+                         (lambda [[(~@ vars)]]
+                           (let [(~@ var-rebinds)]
+                             (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])))))))
+      )))
+
+(do-template [<name> <op>]
+  [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))]
+                              [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^])
+     (do Lux/Monad
+       [[vars var-types var-rebinds arg-classes] (prepare-args args)
+        g!self (gensym "self")
+        g!temp (gensym "temp")
+        #let [return-type (` (^ (~ (symbol$ ["" return]))))
+              body (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)]))
+              [body return-type] (if opt?
+                                   [(` (let [(~ g!temp) (~ body)]
+                                         (if (;_jvm_null? (~ g!temp))
+                                           #;None
+                                           (#;Some (~ g!temp)))))
+                                    (` (Maybe (~ return-type)))]
+                                   [body return-type])
+              [body return-type] (if ex?
+                                   [(` (try (~ body)))
+                                    (` (Either Text (~ return-type)))]
+                                   [body return-type])]]
+       (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type))
+                          (lambda [[(~@ vars)] (~ g!self)]
+                            (let [(~@ var-rebinds)]
+                              (~ body)))))))
+       ))]
+
+  [invoke-virtual$   ;_jvm_invokevirtual]
+  [invoke-interface$ ;_jvm_invokeinterface]
+  )
+
+(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))]
+                                   [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^])
+  (do Lux/Monad
+    [[vars var-types var-rebinds arg-classes] (prepare-args args)
+     g!temp (gensym "temp")
+     #let [return-type (` (^ (~ (symbol$ ["" return]))))
+           body (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)]))
+           [body return-type] (if opt?
+                                [(` (let [(~ g!temp) (~ body)]
+                                      (if (;_jvm_null? (~ g!temp))
+                                        #;None
+                                        (#;Some (~ g!temp)))))
+                                 (` (Maybe (~ return-type)))]
+                                [body return-type])
+           [body return-type] (if ex?
+                                [(` (try (~ body)))
+                                 (` (Either Text (~ return-type)))]
+                                [body return-type])]]
+    (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type))
+                       (lambda [[(~@ vars)]]
+                         (let [(~@ var-rebinds)]
+                           (~ body)))))))
+    ))
diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux
index 5425a2d9c..a28fa6d27 100644
--- a/source/lux/meta/syntax.lux
+++ b/source/lux/meta/syntax.lux
@@ -107,15 +107,13 @@
 
 (do-template [<name> <type> <tag> <eq>]
   [(def #export (<name> v tokens)
-     (-> <type> (Parser (,)))
+     (-> <type> (Parser Bool))
      (case tokens
        (#;Cons [[_ (<tag> x)] tokens'])
-       (if (<eq> v x)
-         (#;Some [tokens' []])
-         #;None)
+       (#;Some [tokens' (<eq> v x)])
 
        _
-       #;None))]
+       (#;Some [tokens false])))]
 
   [  bool?^ Bool    #;BoolS  (:: b;Bool/Eq E;=)]
   [   int?^ Int      #;IntS  i=]
@@ -220,24 +218,22 @@
       (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))]
                 body))
       (do Lux/Monad
-        [names+parsers (M;map% Lux/Monad
-                               (: (-> AST (Lux (, AST AST)))
-                                  (lambda [arg]
-                                    (case arg
-                                      (\ [_ (#;TupleS (@list [_ (#;SymbolS var-name)]
-                                                             parser))])
-                                      (wrap [(symbol$ var-name) parser])
-
-                                      (\ [_ (#;SymbolS var-name)])
-                                      (wrap [(symbol$ var-name) (` id^)])
-
-                                      _
-                                      (l;fail "Syntax pattern expects 2-tuples or symbols."))))
-                               args)
+        [vars+parsers (M;map% Lux/Monad
+                              (: (-> AST (Lux (, AST AST)))
+                                 (lambda [arg]
+                                   (case arg
+                                     (\ [_ (#;TupleS (@list var parser))])
+                                     (wrap [var parser])
+
+                                     (\ [_ (#;SymbolS var-name)])
+                                     (wrap [(symbol$ var-name) (` id^)])
+
+                                     _
+                                     (l;fail "Syntax pattern expects 2-tuples or symbols."))))
+                              args)
          g!tokens (gensym "tokens")
          g!_ (gensym "_")
-         #let [names (:: List/Functor (F;map first names+parsers))
-               error-msg (text$ (text:++ "Wrong syntax for " name))
+         #let [error-msg (text$ (text:++ "Wrong syntax for " name))
                body' (foldL (: (-> AST (, AST AST) AST)
                                (lambda [body name+parser]
                                  (let [[name parser] name+parser]
@@ -248,7 +244,7 @@
                                                   (~ g!_)
                                                   (l;fail (~ error-msg)))))))
                             body
-                            (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers))))
+                            (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers))))
                macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
                               (~ body')))]]
         (wrap (@list& macro-def