Created
February 18, 2022 22:00
-
-
Save MattRoelle/f6a28846ed79001d76fc052006d88802 to your computer and use it in GitHub Desktop.
A smalltalk style object system written in Fennel Lisp
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Using the above as the foundation for a smalltalk / lisp machine inspired editing environment: