reorganization

6 files changed, 407 insertions, 0 deletions

diff --git a/core/base.moon b/core/base.moon
new file mode 100644
index 0000000..1805bea
--- /dev/null
+++ b/core/base.moon
@@ -0,0 +1,69 @@
+class Op
+-- common
+  new: =>
+  -- (...) => @setup ...
+
+  get: => @value
+  getc: =>
+    L\warn "stream #{@} cast to constant"
+    @value
+
+-- Value interface
+  update: =>
+
+  destroy: =>
+
+-- static
+  __tostring: => "<op: #{@@__name}>"
+  __inherited: (cls) => cls.__base.__tostring = @__tostring
+
+  spawn: (Opdef, ...) ->
+    Opdef ...
+
+class Action
+-- common
+  new: (head, @tag, @registry) =>
+    @patch head
+
+  register: =>
+    @tag = @registry\register @, @tag
+
+-- AST interface
+  -- * eval args
+  -- * perform scope effects
+  -- * patch nested exprs
+  -- * return runtime-tree value
+  eval: (scope, tail) => error "not implemented"
+
+  -- free resources
+  destroy: =>
+
+  -- update this instance for :eavl() with new head
+  -- if :patch() returns false, this instance is :destroy'ed and recreated instead
+  -- must *not* return false when called after :new()
+  -- only considered if Action types match
+  patch: (head) =>
+    if head == @head
+      true
+
+    @head = head
+
+-- static
+  @get_or_create: (ActionType, head, tag, registry) ->
+    last = tag and registry\prev tag
+    compatible = last and
+                 (last.__class == ActionType) and
+                 (last\patch head) and
+                 last
+
+    if not compatible
+      last\destroy! if last
+      compatible = ActionType head, tag, registry
+
+    with compatible
+      \register!
+
+  __tostring: => "<action: #{@@__name}>"
+  __inherited: (cls) => cls.__base.__tostring = @__tostring
+
+:Op, :Action
diff --git a/core/cell.moon b/core/cell.moon
new file mode 100644
index 0000000..199c4c3
--- /dev/null
+++ b/core/cell.moon
@@ -0,0 +1,85 @@
+import Const from require 'core.const'
+import op_invoke, fn_invoke from require 'core.invoke'
+
+class Cell
+-- common
+  new: (@tag, @children, @white) =>
+    if not @white
+      @white = ['' for i=1,#@children+1]
+
+  head: => @children[1]
+  tail: => [c for c in *@children[2,]]
+
+-- AST interface
+  eval: (scope, registry) =>
+    head = @head!\eval scope, registry
+    Action = switch head.type
+      when 'opdef'
+        -- scope\get 'op-invoke'
+        op_invoke
+      when 'fndef'
+        -- scope\get 'fn-invoke'
+        fn_invoke
+      when 'builtin'
+        head\getc!
+      else
+        error "cannot evaluate expr with head #{head}"
+
+    action = Action\get_or_create head, @tag, registry
+    @tag or= action.tag
+    action\eval scope, @tail!
+
+  quote: (scope, registry) =>
+    tag = registry\register @, @tag
+    children = [child\quote scope, registry for child in *@children]
+    Cell tag, children, @white
+
+  stringify: (depth=-1) =>
+    buf = ''
+    buf ..= if depth > 0 then '' else @white[0]
+    if depth == 0
+      buf ..= '...'
+    else
+      for i, child in ipairs @children
+        buf ..= child\stringify depth - 1
+        buf ..= if depth > 0 then ' ' else @white[i]
+
+      if depth > 0
+        buf = buf\sub 1, #buf - 1
+
+    tag = if @tag then "[#{@tag\stringify!}]" else ''
+    '(' .. tag .. buf .. ')'
+
+-- static
+  __tostring: => @stringify 2
+
+  parse_args = (tag, parts) ->
+    if not parts
+      parts, tag = tag, nil
+
+    children, white = {}, { [0]: parts[1] }
+
+    for i = 2,#parts,2
+      children[i/2] = parts[i]
+      white[i/2] = parts[i+1]
+
+    tag, children, white
+  @parse: (...) =>
+    tag, children, white = parse_args ...
+    @ tag, children, white
+
+class RootCell extends Cell
+  head: => Const.sym 'do'
+  tail: => @children
+
+  stringify: =>
+    buf = ''
+    buf ..= @white[0]
+
+    for i, child in ipairs @children
+      buf ..= child\stringify!
+      buf ..= @white[i]
+
+    buf
+
+:Cell, :RootCell
diff --git a/core/const.moon b/core/const.moon
new file mode 100644
index 0000000..564ab53
--- /dev/null
+++ b/core/const.moon
@@ -0,0 +1,106 @@
+import Op, Action from require 'core.base'
+
+local Scope
+load_ = ->
+  import Scope from require 'core.scope'
+
+ancestor = (klass) ->
+  assert klass, "cant find the ancestor of nil"
+  while klass.__parent
+    klass = klass.__parent
+  klass
+
+class Const
+  types = {
+    sym: true
+    str: true
+    num: true
+    scope: true
+    op: true
+    opdef: true
+    fndef: true
+    builtin: true
+  }
+
+  new: (@type, @value, @raw) =>
+    assert types[@type], "invalid Const type: #{@type}"
+
+-- Value interface
+  get: (type) =>
+    assert not type or type == @type, "#{@} is not a #{type}"
+    @value
+
+  getc: (type) =>
+    assert not type or type == @type, "#{@} is not a #{type}"
+    @value
+
+  update: (dt) =>
+    switch @type
+      when 'op'
+        @value\update dt
+
+-- AST interface
+  eval: (scope) =>
+    switch @type
+      when 'num', 'str'
+        @
+      when 'sym'
+        assert (scope\get @value), "undefined reference to symbol '#{@value}'"
+      else
+        error "cannot evaluate #{@}"
+
+  quote: => @
+
+  stringify: => @raw
+
+-- static
+  __tostring: =>
+    value = if @type == 'opdef' or @type == 'builtin' then @value.__name else @value
+    "<#{@type}: #{value}>"
+
+  __eq: (other) =>
+    other.type == @type and other.value == @value
+
+  unescape = (str) -> str\gsub '\\([\'"\\])', '%1'
+
+  @parse: (type, sep) =>
+    switch type
+      when 'num' then (match) -> @ 'num', (tonumber match), match
+      when 'sym' then (match) -> @ 'sym', match, match
+      when 'str' then (match) -> @ 'str', (unescape match), sep .. match .. sep
+
+  @num: (num) -> Const 'num', num, tostring num
+  @str: (str) -> Const 'str', str, "'#{str}'"
+  @sym: (sym) -> Const 'sym', sym, sym
+  @empty: -> Const 'str', '', "''"
+
+  @wrap: (val, name='(unknown)') ->
+    typ = switch type val
+      when 'number' then 'num'
+      when 'string' then 'str'
+      when 'table'
+        if base = rawget val, '__base'
+          -- a class
+          switch ancestor val
+            when Op then 'opdef'
+            when Action then 'builtin'
+            else
+              error "#{name}: cannot wrap class '#{val.__name}'"
+        elseif val.__class
+          -- an instance
+          switch ancestor val.__class
+            when Op then 'op'
+            when Scope then 'scope'
+            when Const
+              return val
+            else
+              error "#{name}: cannot wrap '#{val.__class.__name}' instance"
+        else
+          -- plain table
+          return Const 'scope', Scope.from_table val
+      else
+        error "#{name}: cannot wrap Lua type '#{type val}'"
+
+    Const typ, val
+
+:Const, :load_
diff --git a/core/init.moon b/core/init.moon
new file mode 100644
index 0000000..713f326
--- /dev/null
+++ b/core/init.moon
@@ -0,0 +1,13 @@
+import Op, Action from require 'core.base'
+
+import Const, load_ from require 'core.const'
+import Scope from require 'core.scope'
+load_!
+
+import Cell, RootCell from require 'core.cell'
+
+{
+  :Const, :Cell, :RootCell
+  :Op, :Action
+  :Scope
+}
diff --git a/core/invoke.moon b/core/invoke.moon
new file mode 100644
index 0000000..78c40a2
--- /dev/null
+++ b/core/invoke.moon
@@ -0,0 +1,79 @@
+import Const from require 'core.const'
+import Action from require 'core.base'
+import Scope from require 'core.scope'
+
+class UpdateChildren
+  new: (@children) =>
+
+  update: (dt) =>
+    for child in *@children
+      L\trace "updating #{child}"
+      L\push child\update, dt
+
+  get: => @children[#@children]\get!
+  getc: => @children[#@children]\getc!
+
+  __tostring: => '<forwarder>'
+
+class op_invoke extends Action
+  patch: (head) =>
+    return true if head == @head
+
+    @op\destroy! if @op
+
+    @head = head
+    assert @head.type == 'opdef', "cant op-invoke #{@head}"
+    @op = @head\getc!!
+  
+    true
+    
+  eval: (scope, tail) =>
+    args = [expr\eval scope, @registry for expr in *tail]
+    -- Const 'op', with @op
+    with @op
+      \setup unpack args
+
+class fn_invoke extends Action
+  -- @TODO:
+  -- need to :patch() the case where the new head is a new fndef
+  -- but corresponds to the last head over time
+
+  patch: (head) =>
+    return true if head == @head
+
+    @head = head
+
+    true
+
+  eval: (scope, tail) =>
+    assert @head.type == 'fndef', "cant fn-invoke #{@head}"
+    { :params, :body } = @head\getc!
+
+    assert #params == #tail, "argument count mismatch in #{@head}"
+
+    fn_scope = Scope @, scope
+
+    for i=1,#params
+      name = params[i]\getc!
+      argm = tail[i]
+      fn_scope\set name, L\push argm\eval, scope, @registry
+
+    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
diff --git a/core/scope.moon b/core/scope.moon
new file mode 100644
index 0000000..a840ba7
--- /dev/null
+++ b/core/scope.moon
@@ -0,0 +1,55 @@
+import Const from require 'core.const'
+
+class Scope
+  new: (@node, @parent) =>
+    @values = {}
+
+  set_raw: (key, val) => @values[key] = Const.wrap val, key
+  set: (key, val) =>
+    L\trace "setting #{key} = #{val} in #{@}"
+    @values[key] = val
+
+  get: (key, prefix='') =>
+    L\debug "checking for #{key} in #{@}"
+    if val = @values[key]
+      L\trace "found #{val} in #{@}"
+      return val
+
+    start, rest = key\match '^(.-)/(.*)'
+
+    if not start
+      return @parent and L\push -> @parent\get key
+
+    scope = @get start
+    assert scope and scope.type == 'scope', "cant find '#{prefix}#{start}' for '#{prefix}#{key}'"
+    scope\getc!\get rest, "#{prefix}#{start}/"
+
+  use: (other) =>
+    for k, v in pairs other.values
+      @values[k] = v
+
+  from_table: (tbl) ->
+    with Scope!
+      .values = { k, Const.wrap v, k for k,v in pairs tbl }
+
+  __tostring: =>
+    buf = "<Scope"
+    buf ..= "@#{@node}" if @node
+
+    depth = -1
+    parent = @parent
+    while parent
+      depth += 1
+      parent = parent.parent
+    buf ..= " ^#{depth}" if depth != 0
+
+    keys = [key for key in pairs @values]
+    if #keys > 5
+      keys = [key for key in *keys[,5]]
+      keys[6] = '...'
+    buf ..= " [#{table.concat keys, ', '}]"
+
+    buf ..= ">"
+    buf
+
+:Scope