new Registry tagging mechanism

7 files changed, 374 insertions, 45 deletions

diff --git a/core/base.moon b/core/base.moon
index 05f7590..3be2a98 100644
--- a/core/base.moon
+++ b/core/base.moon
@@ -22,12 +22,10 @@ class Op
 
 class Action
 -- common
-  new: (head, @tag, @registry) =>
+  new: (head, @tag) =>
+    @registry = @tag.registry -- @TODO: remove
     @patch head
 
-  register: =>
-    @tag = @registry\register @, @tag
-
 -- AST interface
   -- * eval args
   -- * perform scope effects
@@ -49,21 +47,29 @@ class Action
     @head = head
 
 -- static
-  @get_or_create: (ActionType, head, tag, registry) ->
-    last = tag and registry\prev tag
+  @get_or_create: (ActionType, head, tag) ->
+    last = tag\last!
     compatible = last and
                  (last.__class == ActionType) and
                  (last\patch head) and
                  last
 
-    if not compatible
+    L\trace if compatible
+      "reusing #{last} for #{tag} <#{ActionType.__name} #{head}>"
+    else if last
+      "replacing #{last} with new #{tag} <#{ActionType.__name} #{head}>"
+    else
+      "initializing #{tag} <#{ActionType.__name} #{head}>"
+
+    if compatible
+      tag\keep compatible
+      compatible
+    else
       last\destroy! if last
-      compatible = ActionType head, tag, registry
-
-    with compatible
-      \register!
+      with next = ActionType head, tag
+        tag\replace next
 
-  __tostring: => "<action: #{@@__name}>"
+  __tostring: => "<#{@@__name} #{@head}>"
   __inherited: (cls) => cls.__base.__tostring = @__tostring
 
 class FnDef
diff --git a/core/builtin.moon b/core/builtin.moon
new file mode 100644
index 0000000..833f7a0
--- /dev/null
+++ b/core/builtin.moon
@@ -0,0 +1,200 @@
+import Action, FnDef from require 'core.base'
+import Const from require 'core.const'
+import Cell from require 'core.cell'
+import Scope from require 'core.scope'
+import UpdateChildren from require 'core.invoke'
+
+class doc extends Action
+  @doc: "(doc sym) - print documentation in console
+
+prints the docstring for sym in the console"
+
+  eval: (scope, tail) =>
+    assert #tail == 1, "'doc' takes exactly one parameter"
+
+    def = L\push tail[1]\eval, scope, @registry
+    L\print "(doc #{tail[1]\stringify!}):\n#{def\getc!.doc}\n"
+    nil
+
+class def extends Action
+  @doc: "(def sym1 val-expr1
+    [sym2 val-expr2]...) - declare symbols in parent scope
+
+defines the symbols sym1, sym2, ... to resolve to the values of val-expr1, val-expr2, ...
+updates all val-exprs."
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    assert #tail > 1, "'def' requires at least 2 arguments"
+    assert #tail % 2 == 0, "'def' requires an even number of arguments"
+
+    values = L\push ->
+      return for i=1,#tail,2
+        name, val_expr = tail[i], tail[i+1]
+        name = (name\quote scope, @registry)\getc 'sym'
+
+        val = val_expr\eval scope, @registry
+        scope\set name, Const.wrap_ref val
+        val
+
+    UpdateChildren values
+
+class use extends Action
+  @doc: "(use scope1 [scope2]...) - merge scopes into parent scope
+
+adds all symbols from scope1, scope2, ... to the parent scope.
+all scopes have to be eval-time constants."
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    for child in *tail
+      value = L\push child\eval, scope, @registry
+      L\trace @, "merging #{value} into #{scope}"
+      assert value.type == 'scope', "'use' only works on scopes"
+      scope\use value\getc 'scope'
+
+    nil
+
+class require_ extends Action
+  @doc: "(require name-str) - require a module
+
+returns the module's scope
+name-str has to be an eval-time constant."
+
+  eval: (scope,  tail) =>
+    L\trace "evaling #{@}"
+    assert #tail == 1, "'require' takes exactly one parameter"
+
+    name = L\push tail[1]\eval, scope, @registry
+
+    L\trace @, "loading module #{name}"
+    Const.wrap require "lib.#{name\getc 'str'}"
+
+class import_ extends Action
+  @doc: "(import sym1 [sym2]...) - require and define modules
+
+requires modules sym1, sym2, ... and defines them as sym1, sym2, ... in the current scope"
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    assert #tail > 0, "'import' requires at least one arguments"
+
+
+    for child in *tail
+      name = (child\quote scope, @registry)\getc 'sym'
+      scope\set name, Const.wrap require "lib.#{name}"
+
+    nil
+
+class import_star extends Action
+  @doc: "(import* sym1 [sym2]...) - require and use modules
+
+requires modules sym1, sym2, ... and merges them into the current scope"
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    assert #tail > 0, "'import' requires at least one arguments"
+
+
+    for child in *tail
+      name = (child\quote scope, @registry)\getc 'sym'
+      scope\use (Const.wrap require "lib.#{name}")\getc 'scope'
+
+    nil
+
+class fn extends Action
+  @doc: "(fn (p1 [p2]...) body-expr) - declare a (lambda) function
+
+the symbols p1, p2, ... will resolve to the arguments passed to the function."
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    assert #tail == 2, "'fn' takes exactly two arguments"
+    { params, body } = tail
+
+    assert params.__class == Cell, "'fn's first argument has to be an expression"
+    param_symbols = for param in *params.children
+      assert param.type == 'sym', "function parameter declaration has to be a symbol"
+      param\quote scope, @registry
+
+    body = body\quote scope, @registry
+    Const.wrap FnDef param_symbols, body, scope
+
+class defn extends Action
+  @doc: "(defn name-sym (p1 [p2]...) body-expr) - define a function
+
+declares a lambda (see (doc fn)) and defines it in the current scope"
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    assert #tail == 3, "'defn' takes exactly three arguments"
+    { name, params, body } = tail
+
+    name = (name\quote scope, @registry)\getc 'sym'
+    assert params.__class == Cell, "'defn's second argument has to be an expression"
+    param_symbols = for param in *params.children
+      assert param.type == 'sym', "function parameter declaration has to be a symbol"
+      param\quote scope, @registry
+
+    body = body\quote scope, @registry
+    fn = FnDef param_symbols, body, scope
+
+    scope\set name, Const.wrap fn
+
+    nil
+
+class do_expr extends Action
+  @doc: "(do expr1 [expr2]...) - update multiple expressions
+
+evaluates and continously updates expr1, expr2, ...
+the last expression's value is returned."
+
+  eval: (scope, tail) =>
+    UpdateChildren [(expr\eval scope, @registry) or Const.empty! for expr in *tail]
+
+class if_ extends Action
+  @doc: "(if bool then-expr [else-xpr]) - make an eval-time const choice
+
+bool has to be an eval-time constant. If it is truthy, this expression is equivalent
+to then-expr, otherwise it is equivalent to else-xpr if given, or nil otherwise."
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    assert #tail >= 2, "'if' needs at least two parameters"
+    assert #tail <= 3, "'if' needs at most three parameters"
+
+    { xif, xthen, xelse } = tail
+
+    xif = L\push xif\eval, scope, @registry
+    xif = xif\getc!
+
+    if xif
+      xthen\eval scope, @registry
+    elseif xelse
+      xelse\eval scope, @registry
+
+class trace extends Action
+  @doc: "(trace expr) - print an eval-time constant to the console"
+
+  eval: (scope, tail) =>
+    L\trace "evaling #{@}"
+    assert #tail == 1, "'trace' takes exactly one parameter"
+
+    with val = L\push tail[1]\eval, scope, @registry
+      L\print "trace:", val
+
+{
+  :doc, :trace
+
+  :def, :use
+  require: require_
+  import: import_
+  'import*': import_star
+
+  true: Const.bool true
+  false: Const.bool false
+
+  :fn, :defn
+  'do': do_expr
+  if: if_
+}
diff --git a/core/cell.moon b/core/cell.moon
index 8f31f27..65273d8 100644
--- a/core/cell.moon
+++ b/core/cell.moon
@@ -1,5 +1,6 @@
 import Const from require 'core.const'
 import op_invoke, fn_invoke from require 'core.invoke'
+import Tag from require 'core.registry'
 
 class Cell
 -- common
@@ -7,6 +8,9 @@ class Cell
     if not @white
       @white = ['' for i=1,#@children+1]
 
+    if not @tag
+      @tag = Tag.blank!
+
   head: => @children[1]
   tail: => [c for c in *@children[2,]]
 
@@ -25,21 +29,23 @@ class Cell
       when 'builtin'
         head\getc!
       else
+        print head
+        for k,v in pairs head
+          print k,v
+          print head.__class.__name
         error "cannot evaluate expr with head #{head}"
 
-    action = Action\get_or_create head, @tag, registry
-    @tag or= action.tag
+    @tag.registry = registry
+    action = Action\get_or_create head, @tag
     action\eval scope, @tail!
 
   quote: (scope, registry) =>
     children = [child\quote scope, registry for child in *@children]
-    with cell = Cell nil, children, @white
-      cell.tag = registry\register cell, @tag
-      @tag = cell.tag -- for writing back to file
+    Cell @tag, children, @white
 
-  clone: (prefix) =>
-    tag = Const.sym prefix\getc! .. '.' .. @tag\getc!
-    children = [child\clone prefix for child in *@children]
+  clone: (parent) =>
+    tag = @tag\clone parent
+    children = [child\clone parent for child in *@children]
     Cell tag, children, @white
 
   stringify: (depth=-1) =>
@@ -53,10 +59,9 @@ class Cell
         buf ..= if depth > 0 then ' ' else @white[i]
 
       if depth > 0
-        buf = buf\sub 1, #buf - 1
+        buf = buf\sub 1, #b@uf - 1
 
-    tag = if @tag then "[#{@tag\stringify!}]" else ''
-    '(' .. tag .. buf .. ')'
+    '(' .. @tag\stringify! .. buf .. ')'
 
 -- static
   __tostring: => @stringify 2
@@ -91,6 +96,6 @@ class RootCell extends Cell
     buf
 
   @parse: (...) =>
-    @__parent.parse @, (Const.num 0), ...
+    @__parent.parse @, (Tag\parse '0'), ...
 
 :Cell, :RootCell
diff --git a/core/init.moon b/core/init.moon
index c91f0e4..c8f0265 100644
--- a/core/init.moon
+++ b/core/init.moon
@@ -6,28 +6,38 @@ import Const, load_ from require 'core.const'
 import Scope from require 'core.scope'
 load_!
 
+import Registry from require 'core.registry'
+
 import Cell, RootCell from require 'core.cell'
 import cell, program from require 'core.parsing'
 
+globals = Scope.from_table require 'core.builtin'
+
 {
   :Const, :Cell, :RootCell
   :Op, :Action, :FnDef
   :Scope
 
+  :Registry
+  :globals
+
   parse: program\match
   eval: do
     class BuiltinRegistry
       new: =>
-        @last = 1
+        @cnt = 1
+
+      init: (tag, expr) =>
+        tag\set @cnt
+        @cnt += 1
 
-      register: (thing, tag) =>
-        with tag or Const.sym "builtin.#{@last}"
-          @last += 1
+      last: (index) =>
+      replace: (index, expr) =>
 
     registry = BuiltinRegistry!
 
     (str, inject) ->
-      scope = Scope.from_table require 'lib.builtin'
+      scope = Scope nil, globals
       scope\use inject if inject
 
       ast = assert (cell\match str), "failed to parse: #{str}"
diff --git a/core/invoke.moon b/core/invoke.moon
index 9955bce..9c324e1 100644
--- a/core/invoke.moon
+++ b/core/invoke.moon
@@ -7,7 +7,7 @@ class UpdateChildren
 
   update: (dt) =>
     for child in *@children
-      L\trace "updating #{child}"
+      -- L\trace "updating #{child}"
       L\push child\update, dt
 
   get: => @children[#@children]\get!
@@ -28,7 +28,9 @@ class op_invoke extends Action
     true
     
   eval: (scope, tail) =>
-    args = [expr\eval scope, @registry for expr in *tail]
+    L\trace "evaling #{@}"
+    args = L\push -> [L\push expr\eval, scope, @registry for expr in *tail]
+
     -- Const 'op', with @op
     with @op
       \setup unpack args
@@ -63,19 +65,10 @@ class fn_invoke extends Action
     body\eval fn_scope, @registry
 
 class do_expr extends Action
-  class DoWrapper
-    new: (@children) =>
-
-    update: (dt) =>
-      for child in *@children
-        L\push child\update, dt
-
-    get: => @children[#@children]\get!
-    getc: => @children[#@children]\getc!
-
-    __tostring: => '<dowrapper>'
-
   eval: (scope, tail) =>
     UpdateChildren [(expr\eval scope, @registry) or Const.empty! for expr in *tail]
 
-:op_invoke, :fn_invoke
+{
+  :op_invoke, :fn_invoke
+  :UpdateChildren
+}
diff --git a/core/parsing.moon b/core/parsing.moon
index 5186cb8..c23b7b7 100644
--- a/core/parsing.moon
+++ b/core/parsing.moon
@@ -1,5 +1,6 @@
 import Const from require 'core.const'
 import Cell, RootCell from require 'core.cell'
+import Tag from require 'core.registry'
 import R, S, P, V, C, Ct from require 'lpeg'
 
 -- whitespace
@@ -29,7 +30,7 @@ atom = num + sym + str
 expr = (V 'cell') + atom
 explist = Ct mspace * (V 'expr') * (space * (V 'expr'))^0 * mspace
 
-tag = (P '[') * atom * (P ']')
+tag = (P '[') * (digit^1 / Tag\parse) * (P ']')
 cell = (P '(') * tag^-1 * (V 'explist') * (P ')') / Cell\parse
 
 root = P {
diff --git a/core/registry.moon b/core/registry.moon
new file mode 100644
index 0000000..7c89fa4
--- /dev/null
+++ b/core/registry.moon
@@ -0,0 +1,114 @@
+import Const from require 'core.const'
+import Scope from require 'core.scope'
+
+local ClonedTag
+
+class Tag
+  new: (@value) =>
+
+  clone: (parent) => ClonedTag @, parent
+
+  last: =>
+    if index = @index!
+      @registry\last index
+
+  keep: (expr) =>
+    index = assert @index!
+    assert expr == @registry\last index
+    @registry\replace index, expr
+
+  replace: (expr) =>
+    if index = @index!
+      @registry\replace index, expr
+    else
+      @registry\init @, expr
+
+index: => @value
+
+  set: (value) =>
+    assert not @value, "setting #{@} again"
+    @value = value
+
+  @blank: -> Tag!
+  @parse: (num) => @ tonumber num
+
+  stringify: => if @value then "[#{@value}]" else ''
+
+  __tostring: => if @value then "#{@value}" else '[blank]'
+
+class ClonedTag extends Tag
+  class DummyReg
+    destroy: =>
+
+  new: (@original, @parent) =>
+    @registry = @original.registry
+    @dummy = DummyReg!
+
+  keep: (expr) =>
+    super\keep expr
+    @original.registry or= @registry
+    @original\replace @dummy
+
+  replace: (expr) =>
+    super\replace expr
+    @original.registry or= @registry
+    @original\replace @dummy
+
+  index: =>
+    orig = @original\index!
+    parent = @parent\index!
+    if orig and parent
+      "#{parent}.#{orig}"
+
+  set: (value) => @original\set value
+
+  stringify: => error "cant stringify ClonedTag"
+
+  __tostring: =>
+    if @parent
+      "#{@parent}.#{@original}"
+    else
+      tostring @original
+
+class Registry
+  new: () =>
+    @map = {}
+
+-- methods for Tag
+
+  last: (index) => @last_map[index]
+
+  replace: (index, expr) =>
+    L\trace "reg: setting #{index} to #{expr}"
+    assert not @map[index], "duplicate tags with index #{index}!"
+    @map[index] = expr
+
+  init: (tag, expr) =>
+    L\trace "reg: init pending to #{expr}"
+    table.insert @pending, { :tag, :expr }
+
+-- public methods
+
+  prepare: =>
+    @last_map, @map, @pending = @map, {}, {}
+
+  finalize: =>
+    for tag, val in pairs @last_map
+      if not @map[tag]
+        val\destroy!
+
+    for { :tag, :expr } in *@pending
+      -- tag was solved by another pending registration
+      -- (e.g. first [A] is solved, then [5.A] is solved)
+      continue if tag\index!
+
+      L\trace "assigning new tag #{value} to #{tag} #{expr}"
+      tag\set @next_tag!
+      @map[tag\index!] = expr
+
+  next_tag: => #@map + 1
+
+{
+  :Tag
+  :Registry
+}