- Migrated function analysis to stdlib.

2 files changed, 112 insertions, 1 deletions

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 _)