- More refactoring.

5 files changed, 53 insertions, 72 deletions

diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux
index 1eb2b8b37..b14524559 100644
--- a/new-luxc/source/luxc/lang/analysis/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/common.lux
@@ -13,8 +13,7 @@
 (def: #export (with-unknown-type action)
   (All [a] (-> (Meta Analysis) (Meta [Type Analysis])))
   (do meta;Monad<Meta>
-    [[var-id var-type] (&;with-type-env
-                         tc;var)
+    [[var-id var-type] (&;with-type-env tc;var)
      analysis (&;with-expected-type var-type
                 action)
      analysis-type (&;with-type-env
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
index 0bb46aba1..2a9826683 100644
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -39,17 +39,14 @@
 
             #;None
             (&;throw Invalid-Function-Type (%type expectedT)))
-          
-          (#;UnivQ _)
-          (do @
-            [[var-id var] (&;with-type-env
-                            tc;existential)]
-            (recur (maybe;assume (type;apply (list var) expectedT))))
 
-          (#;ExQ _)
-          (do @
-            [[var-id var] (&;with-type-env tc;var)]
-            (recur (maybe;assume (type;apply (list var) expectedT))))
+          (^template [<tag> <instancer>]
+            (<tag> _)
+            (do @
+              [[_ instanceT] (&;with-type-env <instancer>)]
+              (recur (maybe;assume (type;apply (list instanceT) expectedT)))))
+          ([#;UnivQ tc;existential]
+           [#;ExQ tc;var])
           
           (#;Var id)
           (do @
@@ -106,5 +103,5 @@
                                                                   (format "\n  " (%n idx) " " (%code argC))))
                                                       (text;join-with "")))))
     (do meta;Monad<Meta>
-      [[applyT argsA] (&inference;apply-function analyse funcT args)]
+      [[applyT argsA] (&inference;general analyse funcT args)]
       (wrap (la;apply argsA funcA)))))
diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux
index 934ecafa5..5152de0b6 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -6,7 +6,7 @@
              [text]
              text/format
              (coll [list "list/" Functor<List>]))
-       [meta #+ Monad<Meta>]
+       [meta "meta/" Monad<Meta>]
        (meta [type]
              (type ["tc" check])))
   (luxc ["&" base]
@@ -95,23 +95,23 @@
 ## tagged variants).
 ## But, so long as the type being used for the inference can be treated
 ## as a function type, this method of inference should work.
-(def: #export (apply-function analyse inferT args)
+(def: #export (general analyse inferT args)
   (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)]))
   (case args
     #;Nil
-    (do Monad<Meta>
+    (do meta;Monad<Meta>
       [_ (&;infer inferT)]
       (wrap [inferT (list)]))
     
     (#;Cons argC args')
     (case inferT
       (#;Named name unnamedT)
-      (apply-function analyse unnamedT args)
+      (general analyse unnamedT args)
 
       (#;UnivQ _)
-      (do Monad<Meta>
+      (do meta;Monad<Meta>
         [[var-id varT] (&;with-type-env tc;var)
-         [outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)]
+         [outputT argsA] (general analyse (maybe;assume (type;apply (list varT) inferT)) args)]
         (do @
           [? (&;with-type-env
                (tc;concrete? var-id))
@@ -124,15 +124,15 @@
           (wrap [outputT' argsA])))
 
       (#;ExQ _)
-      (do Monad<Meta>
+      (do meta;Monad<Meta>
         [[ex-id exT] (&;with-type-env
                        tc;existential)]
-        (apply-function analyse (maybe;assume (type;apply (list exT) inferT)) args))
+        (general analyse (maybe;assume (type;apply (list exT) inferT)) args))
 
       (#;Apply inputT transT)
       (case (type;apply (list inputT) transT)
         (#;Some outputT)
-        (apply-function analyse outputT args)
+        (general analyse outputT args)
 
         #;None
         (&;throw Invalid-Type-Application (%type inferT)))
@@ -145,8 +145,8 @@
       ## avoided in Lux code, since the inference algorithm can piece
       ## things together more easily.
       (#;Function inputT outputT)
-      (do Monad<Meta>
-        [[outputT' args'A] (apply-function analyse outputT args')
+      (do meta;Monad<Meta>
+        [[outputT' args'A] (general analyse outputT args')
          argA (&;with-stacked-errors
                 (function [_] (Cannot-Infer-Argument
                                (format "Inferred Type: " (%type inputT) "\n"
@@ -174,14 +174,14 @@
 
     (^template [<tag>]
       (<tag> env bodyT)
-      (do Monad<Meta>
+      (do meta;Monad<Meta>
         [bodyT+ (record bodyT)]
         (wrap (<tag> env bodyT+))))
     ([#;UnivQ]
      [#;ExQ])
 
     (#;Product _)
-    (:: Monad<Meta> wrap (type;function (type;flatten-tuple type) type))
+    (meta/wrap (type;function (type;flatten-tuple type) type))
 
     _
     (&;throw Not-A-Record-Type (%type type))))
@@ -193,13 +193,13 @@
          currentT type]
     (case currentT
       (#;Named name unnamedT)
-      (do Monad<Meta>
+      (do meta;Monad<Meta>
         [unnamedT+ (recur depth unnamedT)]
         (wrap unnamedT+))
 
       (^template [<tag>]
         (<tag> env bodyT)
-        (do Monad<Meta>
+        (do meta;Monad<Meta>
           [bodyT+ (recur (n.inc depth) bodyT)]
           (wrap (<tag> env bodyT+))))
       ([#;UnivQ]
@@ -214,11 +214,11 @@
                        (n.< boundary tag)))
               (case (list;nth tag cases)
                 (#;Some caseT)
-                (:: Monad<Meta> wrap (if (n.= +0 depth)
-                                       (type;function (list caseT) currentT)
-                                       (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
-                                         (type;function (list (replace! caseT))
-                                           (replace! currentT)))))
+                (meta/wrap (if (n.= +0 depth)
+                             (type;function (list caseT) currentT)
+                             (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+                               (type;function (list (replace! caseT))
+                                 (replace! currentT)))))
 
                 #;None
                 (&common;variant-out-of-bounds-error type expected-size tag))
@@ -230,11 +230,11 @@
 
               (n.= boundary tag)
               (let [caseT (type;variant (list;drop boundary cases))]
-                (:: Monad<Meta> wrap (if (n.= +0 depth)
-                                       (type;function (list caseT) currentT)
-                                       (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
-                                         (type;function (list (replace! caseT))
-                                           (replace! currentT))))))
+                (meta/wrap (if (n.= +0 depth)
+                             (type;function (list caseT) currentT)
+                             (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+                               (type;function (list (replace! caseT))
+                                 (replace! currentT))))))
               
               ## else
               (&common;variant-out-of-bounds-error type expected-size tag)))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
index fa10a7a1c..39ca0eb43 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
@@ -24,7 +24,7 @@
         ["&;" host]
         (lang ["la" analysis]
               (analysis ["&;" common]
-                        ["&;" inference])))
+                        [";A" inference])))
   ["@" ../common]
   )
 
@@ -367,11 +367,8 @@
       (^ (list objectC))
       (do meta;Monad<Meta>
         [_ (&;infer Bool)
-         [var-id varT] (&;with-type-env tc;var)
-         objectA (&;with-expected-type varT
-                   (analyse objectC))
-         objectT (&;with-type-env
-                   (tc;read var-id))
+         [objectT objectA] (&common;with-unknown-type
+                             (analyse objectC))
          _ (check-object objectT)]
         (wrap (la;procedure proc (list objectA))))
 
@@ -384,11 +381,8 @@
     (case args
       (^ (list monitorC exprC))
       (do meta;Monad<Meta>
-        [[var-id varT] (&;with-type-env tc;var)
-         monitorA (&;with-expected-type varT
-                    (analyse monitorC))
-         monitorT (&;with-type-env
-                    (tc;read var-id))
+        [[monitorT monitorA] (&common;with-unknown-type
+                               (analyse monitorC))
          _ (check-object monitorT)
          exprA (analyse exprC)]
         (wrap (la;procedure proc (list monitorA exprA))))
@@ -483,11 +477,8 @@
       (^ (list exceptionC))
       (do meta;Monad<Meta>
         [_ (&;infer Bottom)
-         [var-id varT] (&;with-type-env tc;var)
-         exceptionA (&;with-expected-type varT
-                      (analyse exceptionC))
-         exceptionT (&;with-type-env
-                      (tc;read var-id))
+         [exceptionT exceptionA] (&common;with-unknown-type
+                                   (analyse exceptionC))
          exception-class (check-object exceptionT)
          ? (sub-class? "java.lang.Throwable" exception-class)
          _ (: (Meta Unit)
@@ -793,15 +784,12 @@
 (def: (analyse-object class analyse sourceC)
   (-> Text &;Analyser Code (Meta [Type la;Analysis]))
   (do meta;Monad<Meta>
-    [[var-id varT] (&;with-type-env tc;var)
-     target-class (load-class class)
+    [target-class (load-class class)
      targetT (java-type-to-lux-type fresh-mappings
                                     (:! java.lang.reflect.Type
                                         target-class))
-     sourceA (&;with-expected-type varT
-               (analyse sourceC))
-     sourceT (&;with-type-env
-               (tc;read var-id))
+     [sourceT sourceA] (&common;with-unknown-type
+                         (analyse sourceC))
      [unboxed castT] (cast #Out targetT sourceT)
      _ (&;assert Cannot-Cast (cannot-cast targetT sourceT)
                  (not (dict;contains? unboxed boxes)))]
@@ -810,11 +798,8 @@
 (def: (analyse-input analyse targetT sourceC)
   (-> &;Analyser Type Code (Meta [Type Text la;Analysis]))
   (do meta;Monad<Meta>
-    [[var-id varT] (&;with-type-env tc;var)
-     sourceA (&;with-expected-type varT
-               (analyse sourceC))
-     sourceT (&;with-type-env
-               (tc;read var-id))
+    [[sourceT sourceA] (&common;with-unknown-type
+                         (analyse sourceC))
      [unboxed castT] (cast #In targetT sourceT)]
     (wrap [castT unboxed sourceA])))
 
@@ -1134,7 +1119,7 @@
       (do meta;Monad<Meta>
         [#let [argsT (list/map product;left argsTC)]
          [methodT exceptionsT] (methods class method #Static argsT)
-         [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+         [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC))
          [unboxed castT] (infer-out outputT)]
         (wrap (la;procedure proc (list& (code;text class) (code;text method)
                                         (code;text unboxed) (decorate-inputs argsT argsA)))))
@@ -1151,7 +1136,7 @@
       (do meta;Monad<Meta>
         [#let [argsT (list/map product;left argsTC)]
          [methodT exceptionsT] (methods class method #Virtual argsT)
-         [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+         [outputT allA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
          #let [[objectA argsA] (case allA
                                  (#;Cons objectA argsA)
                                  [objectA argsA]
@@ -1174,7 +1159,7 @@
       (do meta;Monad<Meta>
         [#let [argsT (list/map product;left argsTC)]
          [methodT exceptionsT] (methods class method #Special argsT)
-         [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+         [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
          [unboxed castT] (infer-out outputT)]
         (wrap (la;procedure proc (list& (code;text class) (code;text method)
                                         (code;text unboxed) (decorate-inputs argsT argsA)))))
@@ -1194,7 +1179,7 @@
          _ (&;assert Non-Interface class-name
                      (Modifier.isInterface [(Class.getModifiers [] class)]))
          [methodT exceptionsT] (methods class-name method #Interface argsT)
-         [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+         [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
          [unboxed castT] (infer-out outputT)]
         (wrap (la;procedure proc
                             (list& (code;text class-name) (code;text method) (code;text unboxed)
@@ -1212,7 +1197,7 @@
       (do meta;Monad<Meta>
         [#let [argsT (list/map product;left argsTC)]
          [methodT exceptionsT] (constructor-methods class argsT)
-         [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+         [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC))
          [unboxed castT] (infer-out outputT)]
         (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
 
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index b7047e105..e1f4de1d7 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -217,7 +217,7 @@
       (do @
         [#let [case-size (list;size group)]
          inferenceT (&inference;variant idx case-size variantT)
-         [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC))
+         [inferredT valueA+] (&inference;general analyse inferenceT (list valueC))
          temp &scope;next-local]
         (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume))))
 
@@ -303,7 +303,7 @@
       (#;Var _)
       (do @
         [inferenceT (&inference;record recordT)
-         [inferredT membersA] (&inference;apply-function analyse inferenceT membersC)]
+         [inferredT membersA] (&inference;general analyse inferenceT membersC)]
         (wrap (la;product membersA)))
 
       _