Partially factored-out the macro-expansion machinery.

6 files changed, 135 insertions, 113 deletions

diff --git a/stdlib/source/lux/tool/compiler/default/evaluation.lux b/stdlib/source/lux/tool/compiler/default/evaluation.lux
index 1f21304ca..68fda1e7d 100644
--- a/stdlib/source/lux/tool/compiler/default/evaluation.lux
+++ b/stdlib/source/lux/tool/compiler/default/evaluation.lux
@@ -10,7 +10,8 @@
    ["." phase
     [analysis (#+ Operation)
      [".A" expression]
-     ["." type]]
+     ["." type]
+     [macro (#+ Expander)]]
     ["." synthesis
      [".S" expression]]
     ["." translation]]])
@@ -18,19 +19,21 @@
 (type: #export Eval
   (-> Nat Type Code (Operation Any)))
 
-(def: #export (evaluator synthesis-state translation-state translate)
+(def: #export (evaluator expander synthesis-state translation-state translate)
   (All [anchor expression statement]
-    (-> synthesis.State+
+    (-> Expander
+        synthesis.State+
         (translation.State+ anchor expression statement)
         (translation.Phase anchor expression statement)
         Eval))
-  (function (eval count type exprC)
-    (do phase.monad
-      [exprA (type.with-type type
-               (expressionA.compile exprC))]
-      (phase.lift (do error.monad
-                    [exprS (|> exprA expressionS.phase (phase.run synthesis-state))]
-                    (phase.run translation-state
-                               (do phase.monad
-                                 [exprO (translate exprS)]
-                                 (translation.evaluate! (format "eval" (%n count)) exprO))))))))
+  (let [analyze (expressionA.phase expander)]
+    (function (eval count type exprC)
+      (do phase.monad
+        [exprA (type.with-type type
+                 (analyze exprC))]
+        (phase.lift (do error.monad
+                      [exprS (|> exprA expressionS.phase (phase.run synthesis-state))]
+                      (phase.run translation-state
+                                 (do phase.monad
+                                   [exprO (translate exprS)]
+                                   (translation.evaluate! (format "eval" (%n count)) exprO)))))))))
diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux
index 8375c4642..8d23b6a4a 100644
--- a/stdlib/source/lux/tool/compiler/default/init.lux
+++ b/stdlib/source/lux/tool/compiler/default/init.lux
@@ -21,6 +21,7 @@
     ["." phase
      ["." analysis
       ["." module]
+      [macro (#+ Expander)]
       [".A" expression]]
      ["." synthesis
       [".S" expression]]
@@ -52,34 +53,36 @@
    #.version //.version
    #.mode #.Build})
 
-(def: refresh
+(def: (refresh expander)
   (All [anchor expression statement]
-    (statement.Operation anchor expression statement Any))
+    (-> Expander (statement.Operation anchor expression statement Any)))
   (do phase.monad
     [[bundle state] phase.get-state
-     #let [eval (evaluation.evaluator (get@ [#statement.synthesis #statement.state] state)
+     #let [eval (evaluation.evaluator expander
+                                      (get@ [#statement.synthesis #statement.state] state)
                                       (get@ [#statement.translation #statement.state] state)
                                       (get@ [#statement.translation #statement.phase] state))]]
-    (phase.set-state [statementE.bundle
+    (phase.set-state [bundle
                       (update@ [#statement.analysis #statement.state]
                                (: (-> analysis.State+ analysis.State+)
                                   (|>> product.right
                                        [(analysisE.bundle eval)]))
                                state)])))
 
-(def: #export (state host translate translation-bundle)
+(def: #export (state expander host translate translation-bundle)
   (All [anchor expression statement]
-    (-> (translation.Host expression statement)
+    (-> Expander
+        (translation.Host expression statement)
         (translation.Phase anchor expression statement)
         (translation.Bundle anchor expression statement)
         (statement.State+ anchor expression statement)))
   (let [synthesis-state [synthesisE.bundle synthesis.init]
         translation-state [translation-bundle (translation.state host)]
-        eval (evaluation.evaluator synthesis-state translation-state translate)
+        eval (evaluation.evaluator expander synthesis-state translation-state translate)
         analysis-state [(analysisE.bundle eval) (analysis.state ..info host)]]
     [statementE.bundle
      {#statement.analysis {#statement.state analysis-state
-                           #statement.phase expressionA.compile}
+                           #statement.phase (expressionA.phase expander)}
       #statement.synthesis {#statement.state synthesis-state
                             #statement.phase expressionS.phase}
       #statement.translation {#statement.state translation-state
@@ -126,22 +129,23 @@
     (|>> module.set-compiled
          statement.lift-analysis))
 
-  (def: (iteration reader)
-    (-> Reader <Operation>)
-    (do phase.monad
-      [code (statement.lift-analysis
-             (..read reader))
-       _ (totalS.phase code)]
-      ..refresh))
-
-  (def: (loop module)
-    (-> Module <Operation>)
+  (def: (iteration expander reader)
+    (-> Expander Reader <Operation>)
+    (let [execute (totalS.phase expander)]
+      (do phase.monad
+        [code (statement.lift-analysis
+               (..read reader))
+         _ (execute code)]
+        (..refresh expander))))
+
+  (def: (loop expander module)
+    (-> Expander Module <Operation>)
     (do phase.monad
       [reader (statement.lift-analysis
                (..reader module syntax.no-aliases))]
       (function (_ state)
         (.loop [state state]
-          (case (..iteration reader state)
+          (case (..iteration expander reader state)
             (#error.Success [state' output])
             (recur state')
 
@@ -150,12 +154,12 @@
               (#error.Success [state []])
               (ex.with-stack ///.cannot-compile module (#error.Failure error))))))))
 
-  (def: (compile hash input)
-    (-> Nat ///.Input <Operation>)
+  (def: (compile expander hash input)
+    (-> Expander Nat ///.Input <Operation>)
     (do phase.monad
       [#let [module (get@ #///.module input)]
        _ (..begin hash input)
-       _ (..loop module)]
+       _ (..loop expander module)]
       (..end module)))
 
   (def: (default-dependencies prelude input)
@@ -165,9 +169,9 @@
       (list prelude)))
   )
 
-(def: #export (compiler prelude state)
+(def: #export (compiler expander prelude state)
   (All [anchor expression statement]
-    (-> Module
+    (-> Expander Module
         (statement.State+ anchor expression statement)
         (Instancer .Module)))
   (function (_ key parameters input)
@@ -180,7 +184,7 @@
                                                               (: (All [anchor expression statement]
                                                                    (statement.Operation anchor expression statement .Module))
                                                                  (do phase.monad
-                                                                   [_ (compile hash input)]
+                                                                   [_ (compile expander hash input)]
                                                                    (statement.lift-analysis
                                                                     (extension.lift
                                                                      macro.current-module)))))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 22c50ddec..d751d2321 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -12,6 +12,8 @@
    ["." syntax]
    ["/." //
     ["." phase
+     [analysis
+      [macro (#+ Expander)]]
      ["." translation]
      ["." statement]]
     ["." cli (#+ Configuration)]
@@ -40,13 +42,14 @@
                   <State+> (as-is (statement.State+ anchor expression statement))
                   <Bundle> (as-is (translation.Bundle anchor expression statement))]
 
-  (def: #export (initialize platform translation-bundle)
+  (def: #export (initialize expander platform translation-bundle)
     (All [! anchor expression statement]
-      (-> <Platform> <Bundle> (! (Error <State+>))))
+      (-> Expander <Platform> <Bundle> (! (Error <State+>))))
     (|> platform
         (get@ #runtime)
         statement.lift-translation
-        (phase.run' (init.state (get@ #host platform)
+        (phase.run' (init.state expander
+                                (get@ #host platform)
                                 (get@ #phase platform)
                                 translation-bundle))
         (:: error.functor map product.left)
@@ -78,9 +81,9 @@
     ##   (io.fail error))
     )
 
-  (def: #export (compile platform configuration state)
+  (def: #export (compile expander platform configuration state)
     (All [! anchor expression statement]
-      (-> <Platform> Configuration <State+> (! (Error Any))))
+      (-> Expander <Platform> Configuration <State+> (! (Error Any))))
     (let [monad (get@ #&monad platform)]
       (do monad
         [input (context.read monad
@@ -92,8 +95,8 @@
          ]
         (wrap (do error.monad
                 [input input
-                 #let [compiler (init.compiler syntax.prelude state)
-                       compilation (compiler init.key (list) input)]]
+                 #let [compile (init.compiler expander syntax.prelude state)
+                       compilation (compile init.key (list) input)]]
                 (case ((get@ #///.process compilation)
                        archive.empty)
                   (#error.Success more|done)
@@ -107,7 +110,7 @@
                   (#error.Failure error)
                   (#error.Failure error))))
         
-        ## (case (compiler input)
+        ## (case (compile input)
         ##   (#error.Failure error)
         ##   (:: monad wrap (#error.Failure error))
 
diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux
index 82c9cd65b..f79d36f4f 100644
--- a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux
+++ b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux
@@ -15,7 +15,7 @@
    ["//." reference]
    ["." case]
    ["." function]
-   ["//." macro]
+   ["//." macro (#+ Expander)]
    ["/." //
     ["." extension]
     [//
@@ -79,8 +79,8 @@
     _
     (else code')))
 
-(def: (compile|others compile code')
-  (-> Phase (-> (Code' (Ann Cursor)) (Operation Analysis)))
+(def: (compile|others expander compile code')
+  (-> Expander Phase (-> (Code' (Ann Cursor)) (Operation Analysis)))
   (case code'
     (#.Identifier reference)
     (//reference.reference reference)
@@ -107,7 +107,7 @@
           (case ?macro
             (#.Some macro)
             (do @
-              [expansion (extension.lift (//macro.expand-one def-name macro argsC+))]
+              [expansion (extension.lift (//macro.expand-one expander def-name macro argsC+))]
               (compile expansion))
 
             _
@@ -119,11 +119,12 @@
     _
     (///.throw unrecognized-syntax [.dummy-cursor code'])))
 
-(def: #export (compile code)
-  Phase
-  (let [[cursor code'] code]
-    ## The cursor must be set in the state for the sake
-    ## of having useful error messages.
-    (//.with-cursor cursor
-      (compile|primitive (compile|structure compile (compile|others compile))
-                         code'))))
+(def: #export (phase expander)
+  (-> Expander Phase)
+  (function (compile code)
+    (let [[cursor code'] code]
+      ## The cursor must be set in the state for the sake
+      ## of having useful error messages.
+      (//.with-cursor cursor
+        (compile|primitive (compile|structure compile (compile|others expander compile))
+                           code')))))
diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux b/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux
index 18455b837..aae26ada7 100644
--- a/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux
+++ b/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux
@@ -27,50 +27,59 @@
                            (list/map (|>> %code (format text.new-line text.tab)))
                            (text.join-with ""))]))
 
-(import: java/lang/reflect/Method
-  (invoke [Object (Array Object)] #try Object))
+(import: #long java/lang/reflect/Method
+  (invoke [java/lang/Object (Array java/lang/Object)] #try java/lang/Object))
 
-(import: (java/lang/Class c)
-  (getMethod [String (Array (Class Object))] #try Method))
+(import: #long (java/lang/Class c)
+  (getMethod [java/lang/String (Array (java/lang/Class java/lang/Object))] #try java/lang/reflect/Method))
 
-(import: java/lang/Object
-  (getClass [] (Class Object)))
+(import: #long java/lang/Object
+  (getClass [] (java/lang/Class java/lang/Object)))
 
 (def: _object-class
-  (Class Object)
-  (host.class-for Object))
+  (java/lang/Class java/lang/Object)
+  (host.class-for java/lang/Object))
 
 (def: _apply-args
-  (Array (Class Object))
-  (|> (host.array (Class Object) 2)
+  (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: #export (expand name macro inputs)
-  (-> Name Macro (List Code) (Meta (List Code)))
+(type: #export Expander
+  (-> Macro (List Code) Lux (Error (Error [Lux (List Code)]))))
+
+(def: #export (jvm macro inputs lux)
+  Expander
+  (do error.monad
+    [apply-method (|> macro
+                      (:coerce java/lang/Object)
+                      (java/lang/Object::getClass)
+                      (java/lang/Class::getMethod "apply" _apply-args))]
+    (:coerce (Error (Error [Lux (List Code)]))
+             (java/lang/reflect/Method::invoke
+              (:coerce java/lang/Object macro)
+              (|> (host.array java/lang/Object 2)
+                  (host.array-write 0 (:coerce java/lang/Object inputs))
+                  (host.array-write 1 (:coerce java/lang/Object lux)))
+              apply-method))))
+
+(def: #export (expand expander name macro inputs)
+  (-> Expander Name Macro (List Code) (Meta (List Code)))
   (function (_ state)
     (do error.monad
-      [apply-method (|> macro
-                        (:coerce Object)
-                        (Object::getClass)
-                        (Class::getMethod "apply" _apply-args))
-       output (Method::invoke (:coerce Object macro)
-                              (|> (host.array Object 2)
-                                  (host.array-write 0 (:coerce Object inputs))
-                                  (host.array-write 1 (:coerce Object state)))
-                              apply-method)]
-      (case (:coerce (Error [Lux (List Code)])
-                     output)
+      [output (expander macro inputs state)]
+      (case output
         (#error.Success output)
         (#error.Success output)
         
         (#error.Failure error)
         ((///.throw expansion-failed [name inputs error]) state)))))
 
-(def: #export (expand-one name macro inputs)
-  (-> Name Macro (List Code) (Meta Code))
+(def: #export (expand-one expander name macro inputs)
+  (-> Expander Name Macro (List Code) (Meta Code))
   (do macro.monad
-    [expansion (expand name macro inputs)]
+    [expansion (expand expander name macro inputs)]
     (case expansion
       (^ (list single))
       (wrap single)
diff --git a/stdlib/source/lux/tool/compiler/phase/statement/total.lux b/stdlib/source/lux/tool/compiler/phase/statement/total.lux
index 542be5408..da2cc387c 100644
--- a/stdlib/source/lux/tool/compiler/phase/statement/total.lux
+++ b/stdlib/source/lux/tool/compiler/phase/statement/total.lux
@@ -12,45 +12,47 @@
     ["." analysis
      ["." expression]
      ["." type]
-     ["///." macro]]
+     ["///." macro (#+ Expander)]]
     ["." extension]]])
 
 (exception: #export (not-a-statement {code Code})
   (ex.report ["Statement" (%code code)]))
 
-(exception: #export (not-a-macro {code Code})
+(exception: #export (not-a-macro-call {code Code})
   (ex.report ["Code" (%code code)]))
 
 (exception: #export (macro-was-not-found {name Name})
   (ex.report ["Name" (%name name)]))
 
-(def: #export (phase code)
-  Phase
-  (case code
-    (^ [_ (#.Form (list& [_ (#.Text name)] inputs))])
-    (extension.apply phase [name inputs])
+(def: #export (phase expander)
+  (-> Expander Phase)
+  (let [analyze (expression.phase expander)]
+    (function (compile code)
+      (case code
+        (^ [_ (#.Form (list& [_ (#.Text name)] inputs))])
+        (extension.apply compile [name inputs])
 
-    (^ [_ (#.Form (list& macro inputs))])
-    (do ///.monad
-      [expansion (//.lift-analysis
-                  (do @
-                    [macroA (type.with-type Macro
-                              (expression.compile macro))]
-                    (case macroA
-                      (^ (analysis.constant macro-name))
+        (^ [_ (#.Form (list& macro inputs))])
+        (do ///.monad
+          [expansion (//.lift-analysis
                       (do @
-                        [?macro (extension.lift (macro.find-macro macro-name))
-                         macro (case ?macro
-                                 (#.Some macro)
-                                 (wrap macro)
-                                 
-                                 #.None
-                                 (///.throw macro-was-not-found macro-name))]
-                        (extension.lift (///macro.expand macro-name macro inputs)))
-                      
-                      _
-                      (///.throw not-a-macro code))))]
-      (monad.map @ phase expansion))
+                        [macroA (type.with-type Macro
+                                  (analyze macro))]
+                        (case macroA
+                          (^ (analysis.constant macro-name))
+                          (do @
+                            [?macro (extension.lift (macro.find-macro macro-name))
+                             macro (case ?macro
+                                     (#.Some macro)
+                                     (wrap macro)
+                                     
+                                     #.None
+                                     (///.throw macro-was-not-found macro-name))]
+                            (extension.lift (///macro.expand expander macro-name macro inputs)))
+                          
+                          _
+                          (///.throw not-a-macro-call code))))]
+          (monad.map @ compile expansion))
 
-    _
-    (///.throw not-a-statement code)))
+        _
+        (///.throw not-a-statement code)))))