- Migrated function analysis to stdlib.

3 files changed, 0 insertions, 299 deletions

diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
deleted file mode 100644
index eaddfa5bb..000000000
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ /dev/null
@@ -1,111 +0,0 @@
-(.module:
-  lux
-  (lux (control monad
-                ["ex" exception #+ exception:])
-       (data [maybe]
-             [text]
-             text/format
-             (coll [list "list/" Fold<List> Monoid<List> Monad<List>]))
-       [macro]
-       (macro [code])
-       (lang [type]
-             (type ["tc" check])))
-  (luxc ["&" lang]
-        (lang ["&." scope]
-              ["la" analysis #+ Analysis]
-              (analysis ["&." common]
-                        ["&." inference])
-              [".L" variable #+ Variable])))
-
-(do-template [<name>]
-  [(exception: #export (<name> {message Text})
-     message)]
-
-  [Cannot-Analyse-Function]
-  [Invalid-Function-Type]
-  [Cannot-Apply-Function]
-  )
-
-## [Analysers]
-(def: #export (analyse-function analyse func-name arg-name body)
-  (-> &.Analyser Text Text Code (Meta Analysis))
-  (do macro.Monad<Meta>
-    [functionT macro.expected-type]
-    (loop [expectedT functionT]
-      (&.with-stacked-errors
-        (function (_ _)
-          (ex.construct Cannot-Analyse-Function
-                        (format "    Type: " (%type expectedT) "\n"
-                                "Function: " func-name "\n"
-                                "Argument: " arg-name "\n"
-                                "    Body: " (%code body))))
-        (case expectedT
-          (#.Named name unnamedT)
-          (recur unnamedT)
-
-          (#.Apply argT funT)
-          (case (type.apply (list argT) funT)
-            (#.Some value)
-            (recur value)
-
-            #.None
-            (&.throw Invalid-Function-Type (%type 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 @
-            [?expectedT' (&.with-type-env
-                           (tc.read id))]
-            (case ?expectedT'
-              (#.Some expectedT')
-              (recur expectedT')
-
-              _
-              ## Inference
-              (do @
-                [[input-id inputT] (&.with-type-env tc.var)
-                 [output-id outputT] (&.with-type-env tc.var)
-                 #let [funT (#.Function inputT outputT)]
-                 funA (recur funT)
-                 _ (&.with-type-env
-                     (tc.check expectedT funT))]
-                (wrap funA))
-              ))
-
-          (#.Function inputT outputT)
-          (<| (:: @ map (function (_ [scope bodyA])
-                          (` ("lux function" [(~+ (list/map code.int (variableL.environment scope)))]
-                              (~ bodyA)))))
-              &.with-scope
-              ## Functions have access not only to their argument, but
-              ## also to themselves, through a local variable.
-              (&scope.with-local [func-name expectedT])
-              (&scope.with-local [arg-name inputT])
-              (&.with-type outputT)
-              (analyse body))
-          
-          _
-          (&.fail "")
-          )))))
-
-(def: #export (analyse-apply analyse funcT funcA args)
-  (-> &.Analyser Type Analysis (List Code) (Meta Analysis))
-  (&.with-stacked-errors
-    (function (_ _)
-      (ex.construct Cannot-Apply-Function
-                    (format " Function: " (%type funcT) "\n"
-                            "Arguments:" (|> args
-                                             list.enumerate
-                                             (list/map (function (_ [idx argC])
-                                                         (format "\n  " (%n idx) " " (%code argC))))
-                                             (text.join-with "")))))
-    (do macro.Monad<Meta>
-      [[applyT argsA] (&inference.general analyse funcT args)]
-      (wrap (la.apply argsA funcA)))))
diff --git a/new-luxc/source/luxc/lang/variable.lux b/new-luxc/source/luxc/lang/variable.lux
deleted file mode 100644
index b33574d19..000000000
--- a/new-luxc/source/luxc/lang/variable.lux
+++ /dev/null
@@ -1,47 +0,0 @@
-(.module:
-  lux
-  (lux (data (coll [list "list/" Functor<List>]))))
-
-(def: #export Variable Int)
-(def: #export Register Nat)
-
-(def: #export (captured register)
-  (-> Register Variable)
-  (|> register n/inc nat-to-int (i/* -1)))
-
-(def: #export (local register)
-  (-> Register Variable)
-  (nat-to-int register))
-
-(def: #export (local-register variable)
-  (-> Variable Register)
-  (int-to-nat variable))
-
-(def: #export (captured-register variable)
-  (-> Variable Register)
-  (|> variable (i/* -1) int-to-nat n/dec))
-
-(do-template [<name> <comp>]
-  [(def: #export (<name> var)
-     (-> Variable Bool)
-     (<comp> 0 var))]
-
-  [self?     i/=]
-  [local?    i/>]
-  [captured? i/<]
-  )
-
-(def: #export (from-ref ref)
-  (-> Ref Variable)
-  (case ref
-    (#.Local register)
-    (local register)
-    
-    (#.Captured register)
-    (captured register)))
-
-(def: #export (environment scope)
-  (-> Scope (List Variable))
-  (|> scope
-      (get@ [#.captured #.mappings])
-      (list/map (function (_ [_ [_ ref]]) (from-ref ref)))))
diff --git a/new-luxc/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux
deleted file mode 100644
index 968de53ef..000000000
--- a/new-luxc/test/test/luxc/lang/analysis/function.lux
+++ /dev/null
@@ -1,141 +0,0 @@
-(.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 [type "type/" Eq<Type>])
-       test)
-  (luxc ["&" lang]
-        (lang ["@." module]
-              ["la" analysis]
-              (analysis [".A" expression]
-                        ["@" function]
-                        ["@." common])))
-  (// common)
-  (test/luxc common))
-
-(def: (check-type expectedT error)
-  (-> Type (e.Error [Type la.Analysis]) Bool)
-  (case error
-    (#e.Success [exprT exprA])
-    (type/= expectedT exprT)
-
-    _
-    false))
-
-(def: (succeeds? error)
-  (All [a] (-> (e.Error a) Bool))
-  (case error
-    (#e.Success _)
-    true
-
-    (#e.Error _)
-    false))
-
-(def: (flatten-apply analysis)
-  (-> la.Analysis [la.Analysis (List la.Analysis)])
-  (case analysis
-    (^code ("lux apply" (~ head) (~ func)))
-    (let [[func' tail] (flatten-apply func)]
-      [func' (#.Cons head tail)])
-
-    _
-    [analysis (list)]))
-
-(def: (check-apply expectedT num-args analysis)
-  (-> Type Nat (Meta la.Analysis) Bool)
-  (|> analysis
-      (&.with-type expectedT)
-      (macro.run (io.run init-jvm))
-      (case> (#e.Success applyA)
-             (let [[funcA argsA] (flatten-apply applyA)]
-               (n/= num-args (list.size argsA)))
-
-             (#e.Error error)
-             false)))
-
-(context: "Function definition."
-  (<| (times +100)
-      (do @
-        [func-name (r.text +5)
-         arg-name (|> (r.text +5) (r.filter (|>> (text/= func-name) not)))
-         [outputT outputC] gen-primitive
-         [inputT _] gen-primitive
-         #let [g!arg (code.local-symbol arg-name)]]
-        ($_ seq
-            (test "Can analyse function."
-                  (and (|> (&.with-type (All [a] (-> a outputT))
-                             (@.analyse-function analyse func-name arg-name outputC))
-                           (macro.run (io.run init-jvm))
-                           succeeds?)
-                       (|> (&.with-type (All [a] (-> a a))
-                             (@.analyse-function analyse func-name arg-name g!arg))
-                           (macro.run (io.run init-jvm))
-                           succeeds?)))
-            (test "Generic functions can always be specialized."
-                  (and (|> (&.with-type (-> inputT outputT)
-                             (@.analyse-function analyse func-name arg-name outputC))
-                           (macro.run (io.run init-jvm))
-                           succeeds?)
-                       (|> (&.with-type (-> inputT inputT)
-                             (@.analyse-function analyse func-name arg-name g!arg))
-                           (macro.run (io.run init-jvm))
-                           succeeds?)))
-            (test "The function's name is bound to the function's type."
-                  (|> (&.with-type (Rec self (-> inputT self))
-                        (@.analyse-function analyse func-name arg-name (code.local-symbol func-name)))
-                      (macro.run (io.run init-jvm))
-                      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 gen-primitive)
-         #let [inputsT (list/map product.left inputsTC)
-               inputsC (list/map product.right inputsTC)]
-         [outputT outputC] gen-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 (n/inc var-idx) inputsT))))
-                         varT)
-               poly-inputT (maybe.assume (list.nth var-idx inputsT))
-               partial-poly-inputsT (list.drop (n/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)]]
-        ($_ seq
-            (test "Can analyse monomorphic type application."
-                  (|> (@.analyse-apply analyse funcT (' []) inputsC)
-                      (check-apply outputT full-args)))
-            (test "Can partially apply functions."
-                  (|> (@.analyse-apply analyse funcT (' []) (list.take partial-args inputsC))
-                      (check-apply partialT partial-args)))
-            (test "Can apply polymorphic functions."
-                  (|> (@.analyse-apply analyse polyT (' []) inputsC)
-                      (check-apply poly-inputT full-args)))
-            (test "Polymorphic partial application propagates found type-vars."
-                  (|> (@.analyse-apply analyse polyT (' []) (list.take (n/inc var-idx) inputsC))
-                      (check-apply partial-polyT1 (n/inc var-idx))))
-            (test "Polymorphic partial application preserves quantification for type-vars."
-                  (|> (@.analyse-apply analyse polyT (' []) (list.take var-idx inputsC))
-                      (check-apply partial-polyT2 var-idx)))
-            ))))