Finishing the meta-compiler [Part 2]

5 files changed, 149 insertions, 53 deletions

diff --git a/stdlib/source/library/lux/tool/compiler/default/platform.lux b/stdlib/source/library/lux/tool/compiler/default/platform.lux
index 42d8b9958..ef79450e9 100644
--- a/stdlib/source/library/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/library/lux/tool/compiler/default/platform.lux
@@ -1,9 +1,9 @@
 (.using
  [library
   [lux "*"
-   [type {"+" :sharing}]
    ["@" target]
    ["[0]" debug]
+   ["[0]" meta]
    [abstract
     ["[0]" monad {"+" Monad do}]]
    [control
@@ -27,6 +27,8 @@
      ["[0]" list ("[1]#[0]" monoid functor mix)]]
     [format
      ["_" binary {"+" Writer}]]]
+   [type {"+" :sharing}
+    ["[0]" check]]
    [world
     ["[0]" file {"+" Path}]
     ["[0]" console]]]]
@@ -49,7 +51,8 @@
      [phase
       ["[0]" extension {"+" Extender}]]]]
    [meta
-    [cli {"+" Compilation Library}]
+    [cli {"+" Compilation Library}
+     ["[0]" compiler {"+" Compiler}]]
     ["[0]" archive {"+" Output Archive}
      ["[0]" registry {"+" Registry}]
      ["[0]" artifact]
@@ -716,6 +719,13 @@
                     [_ (ioW.freeze (value@ #&file_system platform) static archive)]
                     (async#in {try.#Failure error}))))))))
 
+      (exception: .public (invalid_custom_compiler [definition Symbol
+                                                    type Type])
+        (exception.report
+         ["Definition" (%.symbol definition)]
+         ["Expected Type" (%.type ///.Custom)]
+         ["Actual Type" (%.type type)]))
+
       (def: .public (compile phase_wrapper import static expander platform compilation context)
         (All (_ <type_vars>)
           (-> ///phase.Wrapper Import Static Expander <Platform> Compilation <Context> <Return>))
@@ -723,5 +733,28 @@
               compiler (|> (..compiler phase_wrapper expander platform)
                            (serial_compiler import static platform sources)
                            (..parallel context))]
-          (compiler descriptor.runtime module)))
+          (do [! ..monad]
+            [customs (|> compilers
+                         (list#each (function (_ it)
+                                      (let [/#definition (value@ compiler.#definition it)
+                                            [/#module /#name] /#definition
+                                            /#parameters (value@ compiler.#parameters it)]
+                                        (do !
+                                          [[archive state] (compiler descriptor.runtime /#module)
+                                           .let [meta_state (value@ [extension.#state
+                                                                     ///directive.#analysis
+                                                                     ///directive.#state
+                                                                     extension.#state]
+                                                                    state)]
+                                           [_ /#type /#value] (|> /#definition
+                                                                  meta.export
+                                                                  (meta.result meta_state)
+                                                                  async#in)]
+                                          (async#in (if (check.subsumes? ///.Custom /#type)
+                                                      (|> /#value
+                                                          (:as ///.Custom)
+                                                          (function.on /#parameters))
+                                                      (exception.except ..invalid_custom_compiler [/#definition /#type])))))))
+                         (monad.all !))]
+            (compiler descriptor.runtime module))))
       )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/inference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/inference.lux
index 893f9df5a..1b693629a 100644
--- a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/inference.lux
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/inference.lux
@@ -7,6 +7,7 @@
    [control
     [pipe {"+" case>}]
     ["[0]" maybe]
+    ["[0]" try]
     ["[0]" exception {"+" exception:}]]
    [data
     ["[0]" text
@@ -71,6 +72,38 @@
      [id _] (/type.check check.existential)]
     (in {.#Primitive (format ..prefix module "#" (%.nat id)) (list)})))
 
+(def: .public (quantified @var @parameter :it:)
+  (-> check.Var Nat Type Type)
+  (case :it:
+    {.#Primitive name co_variant}
+    {.#Primitive name (list#each (quantified @var @parameter) co_variant)}
+
+    (^template [<tag>]
+      [{<tag> left right}
+       {<tag> (quantified @var @parameter left)
+              (quantified @var @parameter right)}])
+    ([.#Sum]
+     [.#Product]
+     [.#Function]
+     [.#Apply])
+    
+    {.#Var @}
+    (if (n.= @var @)
+      {.#Parameter @parameter}
+      :it:)
+
+    (^template [<tag>]
+      [{<tag> env body}
+       {<tag> (list#each (quantified @var @parameter) env)
+              (quantified @var (n.+ 2 @parameter) body)}])
+    ([.#UnivQ]
+     [.#ExQ])
+
+    (^or {.#Parameter @}
+         {.#Ex @}
+         {.#Named name anonymous})
+    :it:))
+
 ... Type-inference works by applying some (potentially quantified) type
 ... to a sequence of values.
 ... Function types are used for this, although inference is not always
@@ -93,13 +126,13 @@
 
       {.#UnivQ _}
       (do phase.monad
-        [[var_id varT] (/type.check check.var)]
-        (general archive analyse (maybe.trusted (type.applied (list varT) inferT)) args))
+        [[@var :var:] (/type.check check.var)]
+        (general archive analyse (maybe.trusted (type.applied (list :var:) inferT)) args))
 
       {.#ExQ _}
-      (do [! phase.monad]
-        [exT ..existential]
-        (general archive analyse (maybe.trusted (type.applied (list exT) inferT)) args))
+      (do phase.monad
+        [:ex: ..existential]
+        (general archive analyse (maybe.trusted (type.applied (list :ex:) inferT)) args))
 
       {.#Apply inputT transT}
       (case (type.applied (list inputT) transT)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/type.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/type.lux
index 7e06dc71a..c066115ec 100644
--- a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/type.lux
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/type.lux
@@ -43,10 +43,20 @@
     [expectedT (extension.lifted meta.expected_type)]
     (..check (check.check expectedT actualT))))
 
+(def: .public (with_var it)
+  (All (_ a) (-> (-> [check.Var Type] (Operation a))
+                 (Operation a)))
+  (do phase.monad
+    [var (..check check.var)
+     .let [[@it :it:] var]
+     it (it var)
+     _ (..check (check.forget! @it))]
+    (in it)))
+
 (def: .public (inferring action)
   (All (_ a) (-> (Operation a) (Operation [Type a])))
   (do phase.monad
-    [[_ varT] (..check check.var)
-     output (..expecting varT action)
-     knownT (..check (check.clean varT))]
-    (in [knownT output])))
+    [[@it :it:] (..check check.var)
+     it (..expecting :it: action)
+     :it: (..check (check.clean :it:))]
+    (in [:it: it])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux
index 347604a35..b91550f39 100644
--- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux
@@ -6,12 +6,16 @@
     monad]
    [control
     ["[0]" maybe]
-    ["ex" exception {"+" exception:}]]
+    ["[0]" try]
+    ["[0]" exception {"+" exception:}]]
    [data
     ["[0]" text
      ["%" format {"+" format}]]
     [collection
      ["[0]" list ("[1]#[0]" monoid monad)]]]
+   [math
+    [number
+     ["n" nat]]]
    ["[0]" type
     ["[0]" check]]]]
  ["[0]" /// "_"
@@ -30,29 +34,44 @@
                                      function Text
                                      argument Text
                                      body Code])
-  (ex.report ["Type" (%.type expected)]
-             ["Function" function]
-             ["Argument" argument]
-             ["Body" (%.code body)]))
+  (exception.report
+   ["Type" (%.type expected)]
+   ["Function" function]
+   ["Argument" argument]
+   ["Body" (%.code body)]))
 
-(exception: .public (cannot_apply [functionT Type
+(exception: .public (cannot_apply [:function: Type
                                    functionC Code
                                    arguments (List Code)])
-  (ex.report ["Function type" (%.type functionT)]
-             ["Function" (%.code functionC)]
-             ["Arguments" (|> arguments
-                              list.enumeration
-                              (list#each (.function (_ [idx argC])
-                                           (format (%.nat idx) " " (%.code argC))))
-                              (text.interposed text.new_line))]))
+  (exception.report
+   ["Function type" (%.type :function:)]
+   ["Function" (%.code functionC)]
+   ["Arguments" (|> arguments
+                    list.enumeration
+                    (list#each (.function (_ [idx argC])
+                                 (format (%.nat idx) " " (%.code argC))))
+                    (text.interposed text.new_line))]))
 
 (def: .public (function analyse function_name arg_name archive body)
   (-> Phase Text Text Phase)
   (do [! ///.monad]
-    [functionT (///extension.lifted meta.expected_type)]
-    (loop [expectedT functionT]
+    [:function: (///extension.lifted meta.expected_type)]
+    (loop [expectedT :function:]
       (/.with_exception ..cannot_analyse [expectedT function_name arg_name body]
         (case expectedT
+          {.#Function :input: :output:}
+          (<| (# ! each (.function (_ [scope bodyA])
+                          {/.#Function (list#each (|>> /.variable)
+                                                  (/scope.environment scope))
+                                       bodyA}))
+              /scope.with
+              ... Functions have access not only to their argument, but
+              ... also to themselves, through a local variable.
+              (/scope.with_local [function_name expectedT])
+              (/scope.with_local [arg_name :input:])
+              (/type.expecting :output:)
+              (analyse archive body))
+          
           {.#Named name unnamedT}
           (again unnamedT)
 
@@ -62,7 +81,7 @@
             (again value)
 
             {.#None}
-            (/.failure (ex.error cannot_analyse [expectedT function_name arg_name body])))
+            (/.failure (exception.error ..cannot_analyse [expectedT function_name arg_name body])))
 
           (^template [<tag> <instancer>]
             [{<tag> _}
@@ -82,33 +101,34 @@
               ... Inference
               _
               (do !
-                [[input_id inputT] (/type.check check.var)
-                 [output_id outputT] (/type.check check.var)
-                 .let [functionT {.#Function inputT outputT}]
-                 functionA (again functionT)
-                 _ (/type.check (check.check expectedT functionT))]
+                [[@input :input:] (/type.check check.var)
+                 [@output :output:] (/type.check check.var)
+                 .let [:function: {.#Function :input: :output:}]
+                 functionA (again :function:)
+                 specialization (/type.check (check.try (check.identity (list @output) @input)))
+                 :function: (case specialization
+                              {try.#Success :input:'}
+                              (in :function:)
+
+                              {try.#Failure _}
+                              (/type.check
+                               (do [! check.monad]
+                                 [? (check.linked? @input @output)]
+                                 (# ! each
+                                    (|>> {.#Function :input:} (/inference.quantified @input 1) {.#UnivQ (list)})
+                                    (if ?
+                                      (in :input:)
+                                      (check.identity (list @input) @output))))))
+                 _ (/type.check (check.check expectedT :function:))]
                 (in functionA))))
 
-          {.#Function inputT outputT}
-          (<| (# ! each (.function (_ [scope bodyA])
-                          {/.#Function (list#each (|>> /.variable)
-                                                  (/scope.environment scope))
-                                       bodyA}))
-              /scope.with
-              ... Functions have access not only to their argument, but
-              ... also to themselves, through a local variable.
-              (/scope.with_local [function_name expectedT])
-              (/scope.with_local [arg_name inputT])
-              (/type.expecting outputT)
-              (analyse archive body))
-          
           _
           (/.failure "")
           )))))
 
-(def: .public (apply analyse argsC+ functionT functionA archive functionC)
+(def: .public (apply analyse argsC+ :function: functionA archive functionC)
   (-> Phase (List Code) Type Analysis Phase)
-  (<| (/.with_exception ..cannot_apply [functionT functionC argsC+])
+  (<| (/.with_exception ..cannot_apply [:function: functionC argsC+])
       (do ///.monad
-        [[applyT argsA+] (/inference.general archive analyse functionT argsC+)])
+        [[applyT argsA+] (/inference.general archive analyse :function: argsC+)])
       (in (/.reified [functionA argsA+]))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux
index 4632aa193..d747ff070 100644
--- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux
@@ -124,10 +124,10 @@
 (def: lux::is
   Handler
   (function (_ extension_name analyse archive args)
-    (do ////.monad
-      [[var_id varT] (typeA.check check.var)]
-      ((binary varT varT Bit extension_name)
-       analyse archive args))))
+    (<| typeA.with_var
+        (function (_ [@var :var:]))
+        ((binary :var: :var: Bit extension_name)
+         analyse archive args))))
 
 ... "lux try" provides a simple way to interact with the host platform's
 ... error_handling facilities.