From 2b5351eb4624ce3c3ada994caaaea77c9d397eb8 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 15 Oct 2019 00:50:03 -0400
Subject: Compiler extensions have been tested to work.

---
 .../luxc/lang/translation/jvm/extension/common.lux |  2 +-
 new-luxc/source/program.lux                        | 43 ++++++++++++++++++++--
 2 files changed, 41 insertions(+), 4 deletions(-)

(limited to 'new-luxc')

diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux
index a46813232..c3b806dd7 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux
@@ -42,7 +42,7 @@
          (-> Text Phase s (Operation Inst))]
         Handler))
   (function (_ extension-name phase input)
-    (case (<s>.run input parser)
+    (case (<s>.run parser input)
       (#try.Success input')
       (handler extension-name phase input')
 
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index 91b42c981..f975d2a87 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -24,7 +24,7 @@
     [compiler
      [phase
       ["." macro (#+ Expander)]
-      [extension
+      [extension (#+ Phase Bundle Operation Handler Extender)
        ["." analysis #_
         ["#" jvm]]]]
      [default
@@ -60,19 +60,27 @@
   (java/lang/Class java/lang/Object)
   (host.class-for java/lang/Object))
 
-(def: _apply-args
+(def: _apply2-args
   (Array (java/lang/Class java/lang/Object))
   (|> (host.array (java/lang/Class java/lang/Object) 2)
       (host.array-write 0 _object-class)
       (host.array-write 1 _object-class)))
 
+(def: _apply4-args
+  (Array (java/lang/Class java/lang/Object))
+  (|> (host.array (java/lang/Class java/lang/Object) 4)
+      (host.array-write 0 _object-class)
+      (host.array-write 1 _object-class)
+      (host.array-write 2 _object-class)
+      (host.array-write 3 _object-class)))
+
 (def: #export (expander macro inputs lux)
   Expander
   (do try.monad
     [apply-method (|> macro
                       (:coerce java/lang/Object)
                       (java/lang/Object::getClass)
-                      (java/lang/Class::getMethod "apply" _apply-args))]
+                      (java/lang/Class::getMethod "apply" _apply2-args))]
     (:coerce (Try (Try [Lux (List Code)]))
              (java/lang/reflect/Method::invoke
               (:coerce java/lang/Object macro)
@@ -158,6 +166,34 @@
                                     run-ioI
                                     $i.RETURN))))]))
 
+(def: extender
+  Extender
+  ## TODO: Stop relying on coercions ASAP.
+  (<| (:coerce Extender)
+      (function (@self handler))
+      (:coerce Handler)
+      (function (@self name phase))
+      (:coerce Phase)
+      (function (@self parameters))
+      (:coerce Operation)
+      (function (@self state))
+      (:coerce Try)
+      try.assume
+      (:coerce Try)
+      (do try.monad
+        [method (|> handler
+                    (:coerce java/lang/Object)
+                    (java/lang/Object::getClass)
+                    (java/lang/Class::getMethod "apply" _apply4-args))]
+        (java/lang/reflect/Method::invoke
+         (:coerce java/lang/Object handler)
+         (|> (host.array java/lang/Object 4)
+             (host.array-write 0 (:coerce java/lang/Object name))
+             (host.array-write 1 (:coerce java/lang/Object phase))
+             (host.array-write 2 (:coerce java/lang/Object parameters))
+             (host.array-write 3 (:coerce java/lang/Object state)))
+         method))))
+
 (program: [{service /cli.service}]
   (let [(^slots [#/cli.target #/cli.module]) (case service
                                                (#/cli.Compilation configuration) configuration
@@ -171,5 +207,6 @@
                 translation.bundle
                 directive.bundle
                 ..program
+                ..extender
                 service
                 [(packager.package ..program-class) jar-path])))
-- 
cgit v1.2.3