- Migrated function analysis to stdlib.

6 files changed, 248 insertions, 8 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)))))
diff --git a/stdlib/test/test/lux/lang/analysis/function.lux b/stdlib/test/test/lux/lang/analysis/function.lux
new file mode 100644
index 000000000..97ab808a0
--- /dev/null
+++ b/stdlib/test/test/lux/lang/analysis/function.lux
@@ -0,0 +1,111 @@
+(.module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data ["e" error]
+             [maybe]
+             [product]
+             [text "text/" Eq<Text>]
+             text/format
+             (coll [list "list/" Functor<List>]))
+       ["r" math/random "r/" Monad<Random>]
+       [macro]
+       (macro [code])
+       [lang]
+       (lang [type "type/" Eq<Type>]
+             [".L" init]
+             [".L" analysis #+ Analysis]
+             (analysis [".A" type]
+                       [".A" expression]
+                       ["/" function]))
+       test)
+  (// ["_." primitive]
+      ["_." structure]))
+
+(def: analyse (expressionA.analyser (:! lang.Eval [])))
+
+(def: (check-apply expectedT num-args analysis)
+  (-> Type Nat (Meta Analysis) Bool)
+  (|> analysis
+      (typeA.with-type expectedT)
+      (macro.run (initL.compiler []))
+      (case> (#e.Success applyA)
+             (let [[funcA argsA] (analysisL.application applyA)]
+               (n/= num-args (list.size argsA)))
+
+             (#e.Error error)
+             false)))
+
+(context: "Function definition."
+  (<| (times +100)
+      (do @
+        [func-name (r.unicode +5)
+         arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not)))
+         [outputT outputC] _primitive.primitive
+         [inputT _] _primitive.primitive
+         #let [g!arg (code.local-symbol arg-name)]]
+        ($_ seq
+            (test "Can analyse function."
+                  (and (|> (typeA.with-type (All [a] (-> a outputT))
+                             (/.function ..analyse func-name arg-name outputC))
+                           _structure.check-succeeds)
+                       (|> (typeA.with-type (All [a] (-> a a))
+                             (/.function ..analyse func-name arg-name g!arg))
+                           _structure.check-succeeds)))
+            (test "Generic functions can always be specialized."
+                  (and (|> (typeA.with-type (-> inputT outputT)
+                             (/.function ..analyse func-name arg-name outputC))
+                           _structure.check-succeeds)
+                       (|> (typeA.with-type (-> inputT inputT)
+                             (/.function ..analyse func-name arg-name g!arg))
+                           _structure.check-succeeds)))
+            (test "The function's name is bound to the function's type."
+                  (|> (typeA.with-type (Rec self (-> inputT self))
+                        (/.function ..analyse func-name arg-name (code.local-symbol func-name)))
+                      _structure.check-succeeds))
+            ))))
+
+(context: "Function application."
+  (<| (times +100)
+      (do @
+        [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
+         partial-args (|> r.nat (:: @ map (n/% full-args)))
+         var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1))))
+         inputsTC (r.list full-args _primitive.primitive)
+         #let [inputsT (list/map product.left inputsTC)
+               inputsC (list/map product.right inputsTC)]
+         [outputT outputC] _primitive.primitive
+         #let [funcT (type.function inputsT outputT)
+               partialT (type.function (list.drop partial-args inputsT) outputT)
+               varT (#.Bound +1)
+               polyT (<| (type.univ-q +1)
+                         (type.function (list.concat (list (list.take var-idx inputsT)
+                                                           (list varT)
+                                                           (list.drop (inc var-idx) inputsT))))
+                         varT)
+               poly-inputT (maybe.assume (list.nth var-idx inputsT))
+               partial-poly-inputsT (list.drop (inc var-idx) inputsT)
+               partial-polyT1 (<| (type.function partial-poly-inputsT)
+                                  poly-inputT)
+               partial-polyT2 (<| (type.univ-q +1)
+                                  (type.function (#.Cons varT partial-poly-inputsT))
+                                  varT)
+               dummy-function (#analysisL.Function (list) (#analysisL.Variable (#analysisL.Local +1)))]]
+        ($_ seq
+            (test "Can analyse monomorphic type application."
+                  (|> (/.apply ..analyse funcT dummy-function inputsC)
+                      (check-apply outputT full-args)))
+            (test "Can partially apply functions."
+                  (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC))
+                      (check-apply partialT partial-args)))
+            (test "Can apply polymorphic functions."
+                  (|> (/.apply ..analyse polyT dummy-function inputsC)
+                      (check-apply poly-inputT full-args)))
+            (test "Polymorphic partial application propagates found type-vars."
+                  (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC))
+                      (check-apply partial-polyT1 (inc var-idx))))
+            (test "Polymorphic partial application preserves quantification for type-vars."
+                  (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC))
+                      (check-apply partial-polyT2 var-idx)))
+            ))))
diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/analysis/structure.lux
index 5bebe5325..ad6691287 100644
--- a/stdlib/test/test/lux/lang/analysis/structure.lux
+++ b/stdlib/test/test/lux/lang/analysis/structure.lux
@@ -29,7 +29,7 @@
 (def: analyse (expressionA.analyser (:! lang.Eval [])))
 
 (do-template [<name> <on-success> <on-error>]
-  [(def: <name>
+  [(def: #export <name>
      (All [a] (-> (Meta a) Bool))
      (|>> (macro.run (initL.compiler []))
           (case> (#e.Success _)