- Migrated reference analysis to stdlib.

5 files changed, 291 insertions, 5 deletions

diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux
index a22e3d32b..5013246aa 100644
--- a/stdlib/source/lux/lang/analysis/expression.lux
+++ b/stdlib/source/lux/lang/analysis/expression.lux
@@ -13,8 +13,8 @@
              (analysis [".A" type]
                        [".A" primitive]
                        [".A" structure]
+                       [".A" reference]
                        ## [".A" function]
-                       ## [".A" reference]
                        )
              ## [".L" macro]
              ## [".L" extension]
@@ -79,8 +79,8 @@
                (^ (#.Record pairs))
                (structureA.record analyse pairs)
 
-               ## (#.Symbol reference)
-               ## (referenceA.analyse-reference reference)
+               (#.Symbol reference)
+               (referenceA.reference reference)
 
                ## (^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
                ## (do macro.Monad<Meta>
diff --git a/stdlib/source/lux/lang/analysis/reference.lux b/stdlib/source/lux/lang/analysis/reference.lux
new file mode 100644
index 000000000..4192ed118
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis/reference.lux
@@ -0,0 +1,56 @@
+(.module:
+  lux
+  (lux (control monad)
+       [macro]
+       (macro [code])
+       [lang]
+       (lang (type ["tc" check])
+             [".L" scope]
+             [".L" analysis #+ Analysis]
+             (analysis [".A" type]))))
+
+## [Analysers]
+(def: (definition def-name)
+  (-> Ident (Meta Analysis))
+  (do macro.Monad<Meta>
+    [[actualT def-anns _] (macro.find-def def-name)]
+    (case (macro.get-symbol-ann (ident-for #.alias) def-anns)
+      (#.Some real-def-name)
+      (definition real-def-name)
+
+      _
+      (do @
+        [_ (typeA.infer actualT)]
+        (:: @ map (|>> #analysisL.Constant)
+            (macro.normalize def-name))))))
+
+(def: (variable var-name)
+  (-> Text (Meta (Maybe Analysis)))
+  (do macro.Monad<Meta>
+    [?var (scopeL.find var-name)]
+    (case ?var
+      (#.Some [actualT ref])
+      (do @
+        [_ (typeA.infer actualT)]
+        (wrap (#.Some (#analysisL.Variable ref))))
+
+      #.None
+      (wrap #.None))))
+
+(def: #export (reference reference)
+  (-> Ident (Meta Analysis))
+  (case reference
+    ["" simple-name]
+    (do macro.Monad<Meta>
+      [?var (variable simple-name)]
+      (case ?var
+        (#.Some varA)
+        (wrap varA)
+
+        #.None
+        (do @
+          [this-module macro.current-module-name]
+          (definition [this-module simple-name]))))
+
+    _
+    (definition reference)))
diff --git a/stdlib/source/lux/lang/scope.lux b/stdlib/source/lux/lang/scope.lux
new file mode 100644
index 000000000..45008ae24
--- /dev/null
+++ b/stdlib/source/lux/lang/scope.lux
@@ -0,0 +1,173 @@
+(.module:
+  lux
+  (lux (control monad)
+       (data [text "text/" Eq<Text>]
+             text/format
+             [maybe "maybe/" Monad<Maybe>]
+             [product]
+             ["e" error]
+             (coll [list "list/" Functor<List> Fold<List> Monoid<List>]
+                   (dictionary [plist])))
+       [macro])
+  (// [analysis #+ Variable]))
+
+(type: Locals (Bindings Text [Type Nat]))
+(type: Foreign (Bindings Text [Type Variable]))
+
+(def: (is-local? name scope)
+  (-> Text Scope Bool)
+  (|> scope
+      (get@ [#.locals #.mappings])
+      (plist.contains? name)))
+
+(def: (get-local name scope)
+  (-> Text Scope (Maybe [Type Variable]))
+  (|> scope
+      (get@ [#.locals #.mappings])
+      (plist.get name)
+      (maybe/map (function (_ [type value])
+                   [type (#analysis.Local value)]))))
+
+(def: (is-captured? name scope)
+  (-> Text Scope Bool)
+  (|> scope
+      (get@ [#.captured #.mappings])
+      (plist.contains? name)))
+
+(def: (get-captured name scope)
+  (-> Text Scope (Maybe [Type Variable]))
+  (loop [idx +0
+         mappings (get@ [#.captured #.mappings] scope)]
+    (case mappings
+      #.Nil
+      #.None
+
+      (#.Cons [_name [_source-type _source-ref]] mappings')
+      (if (text/= name _name)
+        (#.Some [_source-type (#analysis.Foreign idx)])
+        (recur (inc idx) mappings')))))
+
+(def: (is-ref? name scope)
+  (-> Text Scope Bool)
+  (or (is-local? name scope)
+      (is-captured? name scope)))
+
+(def: (get-ref name scope)
+  (-> Text Scope (Maybe [Type Variable]))
+  (case (get-local name scope)
+    (#.Some type)
+    (#.Some type)
+
+    _
+    (get-captured name scope)))
+
+(def: #export (find name)
+  (-> Text (Meta (Maybe [Type Variable])))
+  (function (_ compiler)
+    (let [[inner outer] (|> compiler
+                            (get@ #.scopes)
+                            (list.split-with (|>> (is-ref? name) not)))]
+      (case outer
+        #.Nil
+        (#.Right [compiler #.None])
+
+        (#.Cons top-outer _)
+        (let [[ref-type init-ref] (maybe.default (undefined)
+                                                 (get-ref name top-outer))
+              [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)])
+                                         (function (_ scope ref+inner)
+                                           [(#analysis.Foreign (get@ [#.captured #.counter] scope))
+                                            (#.Cons (update@ #.captured
+                                                             (: (-> Foreign Foreign)
+                                                                (|>> (update@ #.counter inc)
+                                                                     (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)]))))
+                                                             scope)
+                                                    (product.right ref+inner))]))
+                                      [init-ref #.Nil]
+                                      (list.reverse inner))
+              scopes (list/compose inner' outer)]
+          (#.Right [(set@ #.scopes scopes compiler)
+                    (#.Some [ref-type ref])]))
+        ))))
+
+(def: #export (with-local [name type] action)
+  (All [a] (-> [Text Type] (Meta a) (Meta a)))
+  (function (_ compiler)
+    (case (get@ #.scopes compiler)
+      (#.Cons head tail)
+      (let [old-mappings (get@ [#.locals #.mappings] head)
+            new-var-id (get@ [#.locals #.counter] head)
+            new-head (update@ #.locals
+                              (: (-> Locals Locals)
+                                 (|>> (update@ #.counter inc)
+                                      (update@ #.mappings (plist.put name [type new-var-id]))))
+                              head)]
+        (case (macro.run' (set@ #.scopes (#.Cons new-head tail) compiler)
+                          action)
+          (#e.Success [compiler' output])
+          (case (get@ #.scopes compiler')
+            (#.Cons head' tail')
+            (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head')
+                                  tail')]
+              (#e.Success [(set@ #.scopes scopes' compiler')
+                           output]))
+
+            _
+            (error! "Invalid scope alteration/"))
+
+          (#e.Error error)
+          (#e.Error error)))
+
+      _
+      (#e.Error "Cannot create local binding without a scope."))
+    ))
+
+(do-template [<name> <val-type>]
+  [(def: <name>
+     (Bindings Text [Type <val-type>])
+     {#.counter +0
+      #.mappings (list)})]
+
+  [init-locals   Nat]
+  [init-captured Variable]
+  )
+
+(def: (scope parent-name child-name)
+  (-> (List Text) Text Scope)
+  {#.name     (list& child-name parent-name)
+   #.inner    +0
+   #.locals   init-locals
+   #.captured init-captured})
+
+(def: #export (with-scope name action)
+  (All [a] (-> Text (Meta a) (Meta a)))
+  (function (_ compiler)
+    (let [parent-name (case (get@ #.scopes compiler)
+                        #.Nil
+                        (list)
+                        
+                        (#.Cons top _)
+                        (get@ #.name top))]
+      (case (action (update@ #.scopes
+                             (|>> (#.Cons (scope parent-name name)))
+                             compiler))
+        (#e.Error error)
+        (#e.Error error)
+
+        (#e.Success [compiler' output])
+        (#e.Success [(update@ #.scopes
+                              (|>> list.tail (maybe.default (list)))
+                              compiler')
+                     output])
+        ))
+    ))
+
+(def: #export next-local
+  (Meta Nat)
+  (function (_ compiler)
+    (case (get@ #.scopes compiler)
+      #.Nil
+      (#e.Error "Cannot get next reference when there is no scope.")
+      
+      (#.Cons top _)
+      (#e.Success [compiler (get@ [#.locals #.counter] top)]))))
diff --git a/stdlib/test/test/lux/lang/analysis/reference.lux b/stdlib/test/test/lux/lang/analysis/reference.lux
new file mode 100644
index 000000000..00689f3e0
--- /dev/null
+++ b/stdlib/test/test/lux/lang/analysis/reference.lux
@@ -0,0 +1,57 @@
+(.module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data ["e" error]
+             [ident "ident/" Eq<Ident>])
+       ["r" math/random]
+       [macro #+ Monad<Meta>]
+       (macro [code])
+       [lang]
+       (lang [type "type/" Eq<Type>]
+             [".L" scope]
+             [".L" module]
+             [".L" init]
+             [".L" analysis]
+             (analysis [".A" type]
+                       [".A" expression]))
+       test)
+  (// ["_." primitive]))
+
+(def: analyse (expressionA.analyser (:! lang.Eval [])))
+
+(context: "References"
+  (<| (times +100)
+      (do @
+        [[expectedT _] _primitive.primitive
+         module-name (r.unicode +5)
+         scope-name (r.unicode +5)
+         var-name (r.unicode +5)
+         #let [def-name [module-name var-name]]]
+        ($_ seq
+            (test "Can analyse variable."
+                  (|> (scopeL.with-scope scope-name
+                        (scopeL.with-local [var-name expectedT]
+                          (typeA.with-inference
+                            (..analyse (code.symbol ["" var-name])))))
+                      (macro.run (initL.compiler []))
+                      (case> (^ (#e.Success [inferredT (#analysisL.Variable (#analysisL.Local var))]))
+                             (and (type/= expectedT inferredT)
+                                  (n/= +0 var))
+
+                             _
+                             false)))
+            (test "Can analyse definition."
+                  (|> (do Monad<Meta>
+                        [_ (moduleL.define var-name [expectedT (' {}) []])]
+                        (typeA.with-inference
+                          (..analyse (code.symbol def-name))))
+                      (moduleL.with-module +0 module-name)
+                      (macro.run (initL.compiler []))
+                      (case> (#e.Success [_ inferredT (#analysisL.Constant constant-name)])
+                             (and (type/= expectedT inferredT)
+                                  (ident/= def-name constant-name))
+
+                             _
+                             false)))))))
diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/analysis/structure.lux
index 110717a0a..5bebe5325 100644
--- a/stdlib/test/test/lux/lang/analysis/structure.lux
+++ b/stdlib/test/test/lux/lang/analysis/structure.lux
@@ -26,6 +26,8 @@
        test)
   (// ["_." primitive]))
 
+(def: analyse (expressionA.analyser (:! lang.Eval [])))
+
 (do-template [<name> <on-success> <on-error>]
   [(def: <name>
      (All [a] (-> (Meta a) Bool))
@@ -40,8 +42,6 @@
   [check-fails    false true]
   )
 
-(def: analyse (expressionA.analyser (:! lang.Eval [])))
-
 (def: (check-sum' size tag variant)
   (-> Nat analysisL.Tag analysisL.Variant Bool)
   (let [variant-tag (if (get@ #analysisL.right? variant)