A smalltalk style object system written in Fennel Lisp

fennel-smalltalk.fnl

;; A smalltalk inspired object system for lua and Fennel 
;; Where all operations are implemented via message passing

(local MethodTable {})
(set MethodTable.__index MethodTable)

(fn MethodTable.dispatch-effect [self k obj ...]
  (when (self:get k)
    ((self:get k) obj ...))
  (each [_ ref (pairs self.refs)]
    (when (ref:get k)
      ((ref:get k) obj ...)))) 

(fn MethodTable.get [self k]
  (if (. self.methods k)
    (. self.methods k)
    (accumulate [method nil _ ref (pairs self.refs)
                 :until method]
      (ref:get k))))

(fn MethodTable.clone [self]
  (setmetatable
    {:refs 
     (collect [name ref (pairs self.refs)]
       (values name ref))
     :methods
     (collect [name f (pairs self.methods)]
       (values name f))}
    MethodTable))

(fn MethodTable.serialize [self]
  ;; TODO: serialize function refs as well
  {:refs (collect [name obj (pairs self.refs)]
                  (values name "TODO: FQN"))
   :methods (collect [name f (pairs self.methods)]
                     (values name "TODO: FQN"))})

(fn make-object [_mt]
  (local methodtable (or _mt (setmetatable {:refs {} :methods {}} MethodTable)))
  (local state {})

  (local Primitives
    {:get-methodtable #methodtable
     :get-state #state
     :method 
     (fn [self name f]
       (tset methodtable.methods name f))
     :ref 
     (fn [self other]
       (tset methodtable.refs other.name (other:get-methodtable)))
     :new 
     (fn [self]
       (let [inst (make-object (methodtable:clone))]
         (inst:init!)
         inst))
     :setprop
     (fn [self k v]
       (tset state k v))
     :getprop 
     (fn [self k]
       (. state k))
     :serialize 
     (fn [self]
       {: state
        :methodtable (methodtable:serialize)})})
  (each [k v (pairs Primitives)]
    (tset methodtable.methods k v))

  (local inst 
    {:send
     (fn [self k ...]
       (if (= "!" (k:sub -1))
         (methodtable:dispatch-effect k self ...)
         (methodtable:get k)
         ((methodtable:get k) self ...)
         (error (.. "Unhandled message " k))))})

  (local Object {})

  (var send-cache {})

  (fn Object.__index [self k]
    ;; The only allowable operation on an object is a message send
    (when (not (. send-cache k))
      (tset send-cache k #(self.send $1 k $2 $3 $4 $5 $6 $7 $8 $9)))
    (. send-cache k))

  (fn Object.__newindex [self]
    (error "Invalid operation: Cannot create new index on object"))

  (fn Object.__tostring [self] self.name)

  (setmetatable inst Object))

;; Examples 

(local fennel (require :lib.fennel))

;; Objects are given pascal case names so they are easily distinguishable
(local MyObject (make-object))

;; ":" Is read as "send"
;; Here, we are sending the :method message to the object with some parameters
;; method is one of the primitive message types, it adds a function into the object's method table
(: MyObject :method :hello-world (fn [self] (print "Hello World!")))

;; Prints "Hello World!"
(: MyObject :hello-world)

;; Same as above, infix : comes from lua semantics and is highly convenient
(MyObject:hello-world)

;; Classes are implemented as objects
(local Human (make-object))

(Human:method :greet
  (fn [self]
    ;; All objects have a serializable state table
    ;; getprop is primitive that gets a property from the state
    (let [name (self:getprop :name)]
      (print (if name (.. "Hello, my name is " name)
               "I don't have a name :(")))))

;; :new primitive message is used to create new instances of an object, cloning the methodtable and sending the init! message
(local Matt (Human:new))
(Matt:greet) ;; I don't have a name :(
;; setprop is another primitive, it sets a prop on the state table
(Matt:setprop :name "Matt")
(Matt:greet) ;; Hello, my name is Matt

;; Inheritence and composition is achieved through a mixin system known as "refs"
;; Objects can reference other objects methodtables 

(local BaseClass (make-object))
(BaseClass:method :foo #(print :foo))

(local SubClass1 (make-object))

;; A singular ref is functionally equivalent to inheritence in traditional OOP
(SubClass1:ref BaseClass)
(SubClass1:method :bar #(print :bar))

(SubClass1:bar) ;; prints "bar"

;; foo is actually a reference to BaseClass's method table, not a copy
(SubClass1:foo) ;; prints "foo"
;; If i redefine that method, its instances are updated reflectively 
(BaseClass:method :foo #(print "not-foo"))
(SubClass1:foo) ;; prints "not-foo"

;; I can ref as many objects as I want
(local BaseClass2 (make-object))
(BaseClass2:method :baz #(print :baz))
(SubClass1:ref BaseClass2)

(SubClass1:baz) ;; prints "baz"


;; Methods ending in "!" are known as "effects"
;; They can be implemented by multiple ref'd objects at the same time
;; init! is special effect in that it is called by the new primitive automatically
;; It is the only such special effect

(SubClass1:method :init! #(print "init SubClass1!"))
(SubClass1:new) ;; prints "init SubClass1!" and returns the instance object

(local SubClass2 (make-object))
(SubClass2:ref SubClass1) ;; refs Subclass2, which refs BaseClass1 and BaseClass2
(SubClass2:method :init! #(print "init SubClass2")) 

(local inst (SubClass2:new)) ;; prints "init SubClass2!" and then "InitSubclass1!" and returns the instance object
;; Effect order is guaranteed in LIFO order. ref order matters

;; Effect methods can be called even if no objects implement them
;; Useful for creating extension points and event hooks
(SubClass1:on-draw!) ;; no error, essetially a NOOP

;; Otherwise, If a message is unhandled, errors occur
(SubClass1:i-dont-exist) ;;  will result in Unhandled message i-dont-exist

Using the above as the foundation for a smalltalk / lisp machine inspired editing environment: