From 273c2d517dbafbe6df4d9b9ac65ffd4749e63642 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 16 May 2018 01:06:28 -0400
Subject: - Migrated reference analysis to stdlib.
---
new-luxc/source/luxc/lang.lux | 13 --
new-luxc/source/luxc/lang/analysis/reference.lux | 57 -------
new-luxc/source/luxc/lang/scope.lux | 173 ---------------------
new-luxc/source/luxc/lang/translation.lux | 3 +-
.../test/test/luxc/lang/analysis/reference.lux | 52 -------
stdlib/source/lux/lang/analysis/expression.lux | 6 +-
stdlib/source/lux/lang/analysis/reference.lux | 56 +++++++
stdlib/source/lux/lang/scope.lux | 173 +++++++++++++++++++++
stdlib/test/test/lux/lang/analysis/reference.lux | 57 +++++++
stdlib/test/test/lux/lang/analysis/structure.lux | 4 +-
10 files changed, 292 insertions(+), 302 deletions(-)
delete mode 100644 new-luxc/source/luxc/lang/analysis/reference.lux
delete mode 100644 new-luxc/source/luxc/lang/scope.lux
delete mode 100644 new-luxc/test/test/luxc/lang/analysis/reference.lux
create mode 100644 stdlib/source/lux/lang/analysis/reference.lux
create mode 100644 stdlib/source/lux/lang/scope.lux
create mode 100644 stdlib/test/test/lux/lang/analysis/reference.lux
diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux
index 28dd302c2..c4dff15ec 100644
--- a/new-luxc/source/luxc/lang.lux
+++ b/new-luxc/source/luxc/lang.lux
@@ -51,16 +51,3 @@
(if (n/= underflow idx)
output
(recur (n/dec idx) (format (|> (text.nth idx name) maybe.assume normalize-char) output)))))
-
-(exception: #export (Error {message Text})
- message)
-
-(def: #export (with-error-tracking action)
- (All [a] (-> (Meta a) (Meta a)))
- (function (_ compiler)
- (case (action compiler)
- (#e.Error error)
- ((throw Error error) compiler)
-
- output
- output)))
diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux
deleted file mode 100644
index 56aba35de..000000000
--- a/new-luxc/source/luxc/lang/analysis/reference.lux
+++ /dev/null
@@ -1,57 +0,0 @@
-(.module:
- lux
- (lux (control monad)
- [macro]
- (macro [code])
- (lang (type ["tc" check])))
- (luxc ["&" lang]
- (lang ["&." scope]
- ["la" analysis #+ Analysis]
- [".L" variable #+ Variable])))
-
-## [Analysers]
-(def: (analyse-definition def-name)
- (-> Ident (Meta Analysis))
- (do macro.Monad
- [[actualT def-anns _] (&.with-error-tracking
- (macro.find-def def-name))]
- (case (macro.get-symbol-ann (ident-for #.alias) def-anns)
- (#.Some real-def-name)
- (analyse-definition real-def-name)
-
- _
- (do @
- [_ (&.infer actualT)
- def-name (macro.normalize def-name)]
- (wrap (code.symbol def-name))))))
-
-(def: (analyse-variable var-name)
- (-> Text (Meta (Maybe Analysis)))
- (do macro.Monad
- [?var (&scope.find var-name)]
- (case ?var
- (#.Some [actualT ref])
- (do @
- [_ (&.infer actualT)]
- (wrap (#.Some (` ((~ (code.int (variableL.from-ref ref))))))))
-
- #.None
- (wrap #.None))))
-
-(def: #export (analyse-reference reference)
- (-> Ident (Meta Analysis))
- (case reference
- ["" simple-name]
- (do macro.Monad
- [?var (analyse-variable simple-name)]
- (case ?var
- (#.Some varA)
- (wrap varA)
-
- #.None
- (do @
- [this-module macro.current-module-name]
- (analyse-definition [this-module simple-name]))))
-
- _
- (analyse-definition reference)))
diff --git a/new-luxc/source/luxc/lang/scope.lux b/new-luxc/source/luxc/lang/scope.lux
deleted file mode 100644
index 82d7803e2..000000000
--- a/new-luxc/source/luxc/lang/scope.lux
+++ /dev/null
@@ -1,173 +0,0 @@
-(.module:
- lux
- (lux (control monad)
- (data [text "text/" Eq]
- text/format
- [maybe "maybe/" Monad]
- [product]
- ["e" error]
- (coll [list "list/" Functor Fold Monoid]))
- [macro])
- (luxc ["&" lang]
- (lang [".L" variable #+ Variable])))
-
-(type: Locals (Bindings Text [Type Nat]))
-(type: Captured (Bindings Text [Type Ref]))
-
-(def: (is-local? name scope)
- (-> Text Scope Bool)
- (|> scope
- (get@ [#.locals #.mappings])
- (&.pl-contains? name)))
-
-(def: (get-local name scope)
- (-> Text Scope (Maybe [Type Ref]))
- (|> scope
- (get@ [#.locals #.mappings])
- (&.pl-get name)
- (maybe/map (function (_ [type value])
- [type (#.Local value)]))))
-
-(def: (is-captured? name scope)
- (-> Text Scope Bool)
- (|> scope
- (get@ [#.captured #.mappings])
- (&.pl-contains? name)))
-
-(def: (get-captured name scope)
- (-> Text Scope (Maybe [Type Ref]))
- (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 (#.Captured idx)])
- (recur (n/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 Ref]))
- (case (get-local name scope)
- (#.Some type)
- (#.Some type)
-
- _
- (get-captured name scope)))
-
-(def: #export (find name)
- (-> Text (Meta (Maybe [Type Ref])))
- (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 [Ref (List Scope)] [Ref (List Scope)])
- (function (_ scope ref+inner)
- [(#.Captured (get@ [#.captured #.counter] scope))
- (#.Cons (update@ #.captured
- (: (-> Captured Captured)
- (|>> (update@ #.counter n/inc)
- (update@ #.mappings (&.pl-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 n/inc)
- (update@ #.mappings (&.pl-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 [ ]
- [(def:
- (Bindings Text [Type ])
- {#.counter +0
- #.mappings (list)})]
-
- [init-locals Nat]
- [init-captured Ref]
- )
-
-(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/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index 99328a45f..0899eccf2 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -101,8 +101,7 @@
(analyse macroC)))
[_macroT _macroM _macroV] (case macroA
[_ (#.Symbol macro-name)]
- (&.with-error-tracking
- (macro.find-def macro-name))
+ (macro.find-def macro-name)
_
(&.throw Invalid-Macro (%code code)))
diff --git a/new-luxc/test/test/luxc/lang/analysis/reference.lux b/new-luxc/test/test/luxc/lang/analysis/reference.lux
deleted file mode 100644
index 9ce4a51c1..000000000
--- a/new-luxc/test/test/luxc/lang/analysis/reference.lux
+++ /dev/null
@@ -1,52 +0,0 @@
-(.module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe)
- (data ["e" error])
- ["r" math/random]
- [macro #+ Monad]
- (lang [type "type/" Eq])
- test)
- (luxc (lang ["&." scope]
- ["&." module]
- ["~" analysis]
- (analysis [".A" expression]
- ["@" reference]
- ["@." common])))
- (// common)
- (test/luxc common))
-
-(context: "References"
- (<| (times +100)
- (do @
- [[ref-type _] gen-primitive
- module-name (r.text +5)
- scope-name (r.text +5)
- var-name (r.text +5)]
- ($_ seq
- (test "Can analyse variable."
- (|> (&scope.with-scope scope-name
- (&scope.with-local [var-name ref-type]
- (@common.with-unknown-type
- (@.analyse-reference ["" var-name]))))
- (macro.run (io.run init-jvm))
- (case> (^ (#e.Success [_type (^code ((~ [_ (#.Int var)])))]))
- (type/= ref-type _type)
-
- _
- false)))
- (test "Can analyse definition."
- (|> (do Monad
- [_ (&module.create +0 module-name)
- _ (&module.define [module-name var-name]
- [ref-type (' {}) (:! Bottom [])])]
- (@common.with-unknown-type
- (@.analyse-reference [module-name var-name])))
- (macro.run (io.run init-jvm))
- (case> (#e.Success [_type [_ (#.Symbol def-name)]])
- (type/= ref-type _type)
-
- _
- false)))
- ))))
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
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
+ [[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
+ [?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
+ [?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/format
+ [maybe "maybe/" Monad]
+ [product]
+ ["e" error]
+ (coll [list "list/" Functor Fold Monoid]
+ (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 [ ]
+ [(def:
+ (Bindings Text [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])
+ ["r" math/random]
+ [macro #+ Monad]
+ (macro [code])
+ [lang]
+ (lang [type "type/" Eq]
+ [".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
+ [_ (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 [ ]
[(def:
(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)
--
cgit v1.2.3