alisp.cr

module Lisp
  enum Tag
    Str
    Symbol
    Int
    Builtin
    Lambda
    List
    True
    False
    Nil
  end

  alias LVal = (String | Int64 | List | Nil | Bool | Builtin)
  class List
    property list : Array(Lisp::Object)
    def initialize(@list = [] of Lisp::Object)
    end
    def to_s
      "(" + @list.map { |x| x.to_s.as(String) }.join(" ") + ")"
    end
  end

  struct Lisp::Object
    property tag : Tag
    property value : LVal

    def initialize(@tag, @value)
    end

    def to_s
      case @tag
      when Tag::Symbol
        @value
      when Tag::True
        "#t"
      when Tag::False
        "#f"
      when Tag::Nil
        "nil"
      when Tag::Str
        @value.inspect
      when Tag::Int
        @value.to_s
      when Tag::List
        @value.as(List).to_s
      when Tag::Builtin
        @value.to_s
      else
        "#<undefined #{@tag} #{@value}>"
      end
    end
  end

  class ParseError < Exception; end

  def parse_error(msg : String)
    raise ParseError.new(msg)
  end

  class Token
    property type, value
    def initialize(@type : String, @value : String)
    end
    def to_s
      "Token(#{@type}, #{@value})"
    end
  end

  class Lexer
    class LexError < Exception; end

    @i = 0_i64
    @s = ""

    def initialize
    end

    def skip_ws
      while @i < @s.size && @s[@i].ascii_whitespace?
        @i += 1
      end
    end

    def peek
      @s[@i]
    end

    def lex(s : String) : Array(Token)
      @s, @i = s, 0_i64
      skip_ws
      raise LexError.new("empty input") if @i == @s.size
      buffer = [] of Token
      while @i < @s.size
        skip_ws
        break if @i == @s.size
        char = peek
        if char == '('
          buffer << Token.new("LPAREN", "(")
          @i += 1
        elsif char == ')'
          buffer << Token.new("RPAREN", ")")
          @i += 1
        elsif is_initial? char
          buffer << lex_ident
        elsif char.number?
          buffer << lex_number
        elsif char == '"'
          buffer << lex_string
        else
          raise LexError.new("unknown token")
        end
      end
      buffer
    end

    def lex_string
      # TODO: add support for escape sequences
      @i += 1
      closed = false
      buffer = ""
      while @i < @s.size
        char = peek
        if char == '"'
          @i += 1
          closed = true
          break
        else
          buffer += char
          @i += 1
        end
      end
      raise LexError.new("unterminated string") unless closed
      Token.new("STRING", buffer)
    end

    def is_initial?(c : Char)
      # Is this a valid initial character in a symbol?
      c.ascii_letter? || "+-*/%!?#".includes?(c)
    end

    def lex_ident
      buffer = ""
      buffer += peek
      @i += 1
      while @i < @s.size && (is_initial?(peek) || peek.number?)
        buffer += peek
        @i += 1
      end
      if buffer[0] == '#'
        parse_error("# is not a valid symbol") if buffer.size == 1
        case buffer[1]
        when 't'
          return Token.new("TRUE", "true")
        when 'f'
          return Token.new("FALSE", "false")
        else
          parse_error("invalid sequence #{buffer}")
        end
      elsif buffer == "nil"
        return Token.new("NIL", "nil")
      elsif buffer[0] == '-' && buffer[1] && buffer[1].number?
        return Token.new("NEGINT", buffer)
      else
        Token.new("IDENT", buffer)
      end
    end

    def lex_number
      if peek == '-'
        neg = true
        @i += 1
      else
        neg = false
      end
      buffer = ""
      while @i < @s.size && peek.number?
        buffer += peek
        @i += 1
      end
      if neg
        Token.new("NEGINT", buffer)
      else
        Token.new("POSINT", buffer)
      end
    end
  end

  macro value(tag, val)
    Lisp::Object.new(Tag::{{tag}}, {{val}})
  end

  class Parser
    class ParseError < Exception; end

    @buffer = [] of Lisp::Object
    @tokens = [] of Token
    def parse(@tokens) : Lisp::Object
      @buffer = [] of Lisp::Object
      until @tokens.empty?
        @buffer << parse_elem
      end
      if @buffer.size == 1
        @buffer.first
      else
        value List, List.new(@buffer)
      end
    end

    def parse_elem
      tok = @tokens.shift
      case tok.type
      when "IDENT"
        value Symbol, tok.value
      when "STRING"
        value Str, tok.value
      when "POSINT"
        value Int, tok.value.to_i64
      when "TRUE"
        value True, true
      when "FALSE"
        value False, false
      when "NIL"
        value Nil, nil
      when "NEGINT"
        value Int, tok.value.to_i64
      when "LPAREN"
        parse_list
      else
        parse_error("unknown token #{tok.to_s}")
      end
    end

    def parse_error(msg)
      raise ParseError.new(msg)
    end

    def parse_list
      buffer = [] of Lisp::Object
      closing = false
      until @tokens.empty?
        tok = @tokens.first
        if tok.type == "RPAREN"
          closing = true
          @tokens.shift
          break
        end
        buffer << parse_elem
      end
      parse_error("unclosed list") unless closing
      value List, List.new(buffer)
    end
  end

  class Env
    property parent, env
    def initialize(@parent : Env? = nil)
      @env = {} of String => Lisp::Object
    end

    def [](key)
      if @env.has_key? key
        @env[key]
      elsif @parent
        @parent.as(Env)[key]
      else
        raise KeyError.new("unbound variable #{key}")
      end
    end

    def []=(key, value)
      @env[key] = value
    end

    def set!(key, value)
      # The difference here is that set! will update any existing binding
      # in the current or enclosing env, and only introduce a new binding
      # if none exists, while def introduces a new binding
      # in the current scope and doesn't touch enclosing scopes.
      env = self
      while env
        if env.env.has_key? key
          env[key] = value
          return
        else
          env = env.parent
        end
      end
      self[key] = value
    end

  end

  alias BuiltinProc = Proc(Interpreter, Array(Lisp::Object), Lisp::Object?)

  class Builtin
    property fn : BuiltinProc
    property arity : Int32
    property name : String

    def initialize(@name, @arity, @fn)
    end
    def to_s
      arity = @arity == -1 ? "variadic" : @arity
      "#<builtin fn #{name}(arity: #{arity})>"
    end
  end

  DefaultEnv = Env.new
  LispNil = value(Nil, nil)
  LispFalse = value(False, false)
  LispTrue = value(True, true)

  def error(msg)
    raise Interpreter::RuntimeError.new(msg)
  end

  macro typecheck(val, type)
    {{val}}.tag == Tag::{{type}}
  end

  macro expect(type, arg)
    unless typecheck({{arg}}, {{type}})
      error("Type error: expected " + {{type.stringify}} + ", got " + {{arg}}.tag.to_s)
    end
  end

  def builtin(name, arity, &fn : BuiltinProc)
    f = Builtin.new(name, arity, fn)
    DefaultEnv[name] = value Builtin, f
  end

  builtin("print", -1) do |i, args|
    lprint = ->(val : Lisp::Object) do
      if typecheck(val, Str)
        puts val.value
      else
        puts val.to_s
      end
    end
    args.each { |a| lprint.call i.eval(a).as(Lisp::Object) }
  end

  builtin("size", 1) do |i, args|
    expect List, args.first
    value Int, args.first.value.as(List).list.size.to_i64
  end

  builtin("list", -1) do |i, args|
    value List, List.new(args)
  end

  builtin("+", -1) do |i, args|
    sum = 0_i64
    args.map do |a|
      expect Int, a
      sum += a.value.as(Int64)
    end
    value Int, sum
  end

  builtin("at", 2) do |i, args|
    expect List, args[0]
    expect Int, args[1]
    idx = args[1].value.as(Int64)
    list = args[0].value.as(List).list
    error("index out of bounds") unless list.size > idx
    list[idx]
  end

  builtin("map", 2) do |i, args|
    expect List, args[0]
    expect Builtin, args[1]
    list = args[0].value.as(List).list
    fn = args[1]
    list = list.map { |v| i.eval_call_builtin(fn, [v]).as(Lisp::Object) }
    value List, List.new(list)
  end

  builtin("read", 1) do |i, args|
    expect Str, args[0]
    str = args[0].value.as(String)
    value = Parser.new.parse(Lexer.new.lex(str))
  end

  class Interpreter
    property env : Env
    def initialize()
      @env = DefaultEnv
    end

    def eval(val : Lisp::Object)
      if self_evaluating? val
        return val
      elsif typecheck(val, List)
        eval_list val.value.as(List)
      else
        eval_ident val
      end
    end

    def eval_list(val)
      if val.list.size == 0
        return val
      end
      fn = val.list.first
      return eval_kw(val.list[0].value.as(String), val.list[1..-1]) if keyword?(fn)
      eval_call fn.value.as(String), val.list[1..-1]
    end

    def eval_call(fn : String, args) : Lisp::Object
      fn = @env[fn]
      eval_call_builtin fn, args
    end

    def eval_call_builtin(fn : Lisp::Object, args : Array(Lisp::Object))
      args.map! { |x| self.eval(x).as(Lisp::Object) }
      apply fn, args
    end

    def keyword?(k)
      typecheck(k, Symbol) && ["if", "set!", "def"].includes?(k.value.as(String))
    end

    def eval_kw(kw : String, args : Array(Lisp::Object))
      if kw == "if"
        error("if requires at least 2 args") if args.size < 2
        _else = args.size == 2 ? LispNil : args[2]
        cond = self.eval(args[0])
        if cond != LispNil && cond != LispFalse
          return self.eval args[1]
        elsif args.size == 3
          return self.eval _else
        else
          error("syntax error: if takes 2 or 3 args, got #{args.size}")
        end
      elsif kw == "def" || kw == "set!"
        error("def and set! require exactly 2 args") unless args.size == 2
        error("identifier must be sybmol") unless typecheck(args[0], Symbol)
        key = args[0].value.as(String)
        val = self.eval(args[1]).as(Lisp::Object)
        if kw == "def"
          @env[key] = val
        else
          @env.set! key, val
        end
      else
        error("unimplemented keyword #{kw}")
      end
    end

    class RuntimeError < Exception; end

    def apply(fn, args)
      if typecheck(fn, Builtin)
        argcheck(fn, args)
        val = fn.value.as(Builtin).fn.call self, args
        return val ? val : LispNil
      else
        error("cannot apply non-function #{fn}")
      end
    end

    def argcheck(fn, args)
      fn = fn.value.as(Builtin)
      return true if fn.arity == -1
      return true if fn.arity == args.size
      error("function #{fn.name} expects #{fn.arity} argument(s), got #{args.size}")
    end

    def eval_ident(x)
      @env[x.value]
    end

    def self_evaluating?(val)
      [Tag::Int, Tag::False, Tag::True, Tag::Nil, Tag::Str].includes? val.tag
    end
  end
end

@simenge I apologise for being a bit abrasive in IRC, I think we both could have handled the situation better.

I know pattern matching and I've used pattern matching. It fits fantastically into haskell and languages with algebraic datatypes, but not so much into crystal: you end up being able to do it all with case. Please check out the modifications I made here: https://gist.github.com/RX14/2148e8a57f45dbf89fdddfa945d24e34