- Migrated function analysis to stdlib.

4 files changed, 136 insertions, 7 deletions

diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux
index 6b2ba097d..223f2fb29 100644
--- a/stdlib/source/lux/lang/analysis.lux
+++ b/stdlib/source/lux/lang/analysis.lux
@@ -55,6 +55,8 @@
 
 (type: #export Tuple (List Analysis))
 
+(type: #export Application [Analysis (List Analysis)])
+
 (do-template [<name> <tag>]
   [(def: <name>
      (-> Analysis Analysis)
@@ -103,8 +105,8 @@
     (list/fold (function (_ left right) (#Structure (#Product left right)))
                last prevs)))
 
-(def: #export (apply args func)
-  (-> (List Analysis) Analysis Analysis)
+(def: #export (apply [func args])
+  (-> Application Analysis)
   (list/fold (function (_ arg func) (#Apply arg func)) func args))
 
 (type: #export Analyser
@@ -141,3 +143,13 @@
 
       _
       #.None)))
+
+(def: #export (application analysis)
+  (-> Analysis Application)
+  (case analysis
+    (#Apply head func)
+    (let [[func' tail] (application func)]
+      [func' (#.Cons head tail)])
+
+    _
+    [analysis (list)]))
diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux
index 5013246aa..da1b27a10 100644
--- a/stdlib/source/lux/lang/analysis/expression.lux
+++ b/stdlib/source/lux/lang/analysis/expression.lux
@@ -13,9 +13,7 @@
              (analysis [".A" type]
                        [".A" primitive]
                        [".A" structure]
-                       [".A" reference]
-                       ## [".A" function]
-                       )
+                       [".A" reference])
              ## [".L" macro]
              ## [".L" extension]
              )))
diff --git a/stdlib/source/lux/lang/analysis/function.lux b/stdlib/source/lux/lang/analysis/function.lux
new file mode 100644
index 000000000..f6fea9bb0
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis/function.lux
@@ -0,0 +1,104 @@
+(.module:
+  [lux #- function]
+  (lux (control monad
+                ["ex" exception #+ exception:])
+       (data [maybe]
+             [text]
+             text/format
+             (coll [list "list/" Fold<List> Monoid<List> Monad<List>]))
+       [macro]
+       (macro [code])
+       [lang]
+       (lang [type]
+             (type ["tc" check])
+             [".L" scope]
+             [".L" analysis #+ Analysis Analyser]
+             (analysis [".A" type]
+                       [".A" inference]))))
+
+(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code})
+  (ex.report ["Type" (%type expected)]
+             ["Function" function]
+             ["Argument" argument]
+             ["Body" (%code body)]))
+
+(exception: #export (cannot-apply {function Type} {arguments (List Code)})
+  (ex.report [" Function" (%type function)]
+             ["Arguments" (|> arguments
+                              list.enumerate
+                              (list/map (.function (_ [idx argC])
+                                          (format "\n  " (%n idx) " " (%code argC))))
+                              (text.join-with ""))]))
+
+## [Analysers]
+(def: #export (function analyse function-name arg-name body)
+  (-> Analyser Text Text Code (Meta Analysis))
+  (do macro.Monad<Meta>
+    [functionT macro.expected-type]
+    (loop [expectedT functionT]
+      (lang.with-stacked-errors
+        (.function (_ _)
+          (ex.construct cannot-analyse [expectedT function-name arg-name body]))
+        (case expectedT
+          (#.Named name unnamedT)
+          (recur unnamedT)
+
+          (#.Apply argT funT)
+          (case (type.apply (list argT) funT)
+            (#.Some value)
+            (recur value)
+
+            #.None
+            (lang.fail (ex.construct cannot-analyse [expectedT function-name arg-name body])))
+
+          (^template [<tag> <instancer>]
+            (<tag> _)
+            (do @
+              [[_ instanceT] (typeA.with-env <instancer>)]
+              (recur (maybe.assume (type.apply (list instanceT) expectedT)))))
+          ([#.UnivQ tc.existential]
+           [#.ExQ tc.var])
+          
+          (#.Var id)
+          (do @
+            [?expectedT' (typeA.with-env
+                           (tc.read id))]
+            (case ?expectedT'
+              (#.Some expectedT')
+              (recur expectedT')
+
+              _
+              ## Inference
+              (do @
+                [[input-id inputT] (typeA.with-env tc.var)
+                 [output-id outputT] (typeA.with-env tc.var)
+                 #let [functionT (#.Function inputT outputT)]
+                 functionA (recur functionT)
+                 _ (typeA.with-env
+                     (tc.check expectedT functionT))]
+                (wrap functionA))
+              ))
+
+          (#.Function inputT outputT)
+          (<| (:: @ map (.function (_ [scope bodyA])
+                          (#analysisL.Function (scopeL.environment scope) bodyA)))
+              lang.with-scope
+              ## Functions have access not only to their argument, but
+              ## also to themselves, through a local variable.
+              (scopeL.with-local [function-name expectedT])
+              (scopeL.with-local [arg-name inputT])
+              (typeA.with-type outputT)
+              (analyse body))
+          
+          _
+          (lang.fail "")
+          )))))
+
+(def: #export (apply analyse functionT functionA args)
+  (-> Analyser Type Analysis (List Code) (Meta Analysis))
+  (lang.with-stacked-errors
+    (.function (_ _)
+      (ex.construct cannot-apply [functionT args]))
+    (do macro.Monad<Meta>
+      [[applyT argsA] (inferenceA.general analyse functionT args)]
+      (wrap (analysisL.apply [functionA argsA])))))
diff --git a/stdlib/source/lux/lang/scope.lux b/stdlib/source/lux/lang/scope.lux
index 45008ae24..1995338f4 100644
--- a/stdlib/source/lux/lang/scope.lux
+++ b/stdlib/source/lux/lang/scope.lux
@@ -9,7 +9,7 @@
              (coll [list "list/" Functor<List> Fold<List> Monoid<List>]
                    (dictionary [plist])))
        [macro])
-  (// [analysis #+ Variable]))
+  (// [analysis #+ Variable Register]))
 
 (type: Locals (Bindings Text [Type Nat]))
 (type: Foreign (Bindings Text [Type Variable]))
@@ -163,7 +163,7 @@
     ))
 
 (def: #export next-local
-  (Meta Nat)
+  (Meta Register)
   (function (_ compiler)
     (case (get@ #.scopes compiler)
       #.Nil
@@ -171,3 +171,18 @@
       
       (#.Cons top _)
       (#e.Success [compiler (get@ [#.locals #.counter] top)]))))
+
+(def: (ref-to-variable ref)
+  (-> Ref Variable)
+  (case ref
+    (#.Local register)
+    (#analysis.Local register)
+    
+    (#.Captured register)
+    (#analysis.Foreign register)))
+
+(def: #export (environment scope)
+  (-> Scope (List Variable))
+  (|> scope
+      (get@ [#.captured #.mappings])
+      (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref)))))