1 files changed, 173 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/scope.lux b/new-luxc/source/luxc/lang/scope.lux
new file mode 100644
index 000000000..435b8ef61
--- /dev/null
+++ b/new-luxc/source/luxc/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>]))
+       [meta])
+  (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 (meta;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 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)]))))