├── .gitignore ├── lib ├── @heap-tests.el ├── @stack-tests.el ├── @vector-tests.el ├── @queue-tests.el ├── @stack.el ├── @queue.el ├── @heap.el └── @vector.el ├── Makefile ├── @-mixins.el ├── @-tests.el ├── README.md └── @.el /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | -------------------------------------------------------------------------------- /lib/@heap-tests.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t; -*- 2 | 3 | (require 'ert) 4 | (require '@heap) 5 | (require 'cl-lib) 6 | 7 | (ert-deftest @heap-test () 8 | (let ((h (@! @heap :new #'cdr))) 9 | (@! h :add '(d . 4)) 10 | (@! h :add '(b . 2)) 11 | (@! h :add '(c . 3)) 12 | (@! h :add '(a . 1)) 13 | (should (eq 'a (car (@! h :peek)))) 14 | (should (equal '(a b c d) (mapcar #'car (@! h :to-list)))) 15 | (should 16 | (equal '(a b c d) 17 | (cl-loop until (@! h :emptyp) collect (car (@! h :next))))))) 18 | -------------------------------------------------------------------------------- /lib/@stack-tests.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t; -*- 2 | 3 | (require 'ert) 4 | (require 'cl-lib) 5 | (require '@stack) 6 | 7 | (ert-deftest @stack-test () 8 | (let ((s (@! @stack :new))) 9 | (@! s :push 'a) 10 | (should (eq 'a (@! s :peek))) 11 | (@! s :push 'b) 12 | (@! s :push 'c) 13 | (should 14 | (equal '(c b a) 15 | (@! s :to-list))) 16 | (should (= 3 (@! s :size))) 17 | (should 18 | (equal '(c b a) 19 | (cl-loop until (@! s :emptyp) collect (@! s :pop)))) 20 | (should (= 0 (@! s :size))))) 21 | -------------------------------------------------------------------------------- /lib/@vector-tests.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t; -*- 2 | 3 | (require 'ert) 4 | (require '@vector) 5 | 6 | (ert-deftest @vector-tests () 7 | (let ((v (@! @vector :new))) 8 | (@! v :push 'a) 9 | (@! v :push 'b 'c) 10 | (should (equal '(a b c) (@! v :to-list))) 11 | (should (eq 'c (@! v :pop))) 12 | (should (eq 'a (@! v :get 0))) 13 | (should (eq 'b (@! v :get 1))) 14 | (should (eq 'a (@! v :shift))) 15 | (@! v :unshift 'x 'y 'z) 16 | (setf (@ v 1) 'Y) 17 | (should (equal '(x Y z b) (@! v :to-list)))) 18 | (let ((v (@! @vector :new))) 19 | (setf (@ v :vector-default) :foo) 20 | (should (eq :foo (@ v 100))) 21 | (setf (@ v 3) t) 22 | (should (= 4 (@! v :size))))) 23 | -------------------------------------------------------------------------------- /lib/@queue-tests.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t; -*- 2 | 3 | (require 'ert) 4 | (require 'cl-lib) 5 | (require '@stack) 6 | (require '@queue) 7 | 8 | (ert-deftest @queue-test () 9 | (let ((q (@! @queue :new))) 10 | (@! q :enqueue 0) 11 | (@! q :enqueue 1) 12 | (@! q :dequeue) 13 | (@! q :enqueue 2) 14 | (@! q :enqueue 3) 15 | (should (= 3 (@! q :size))) 16 | (should 17 | (equal '(1 2 3) 18 | (cl-loop until (@! q :emptyp) collect (@! q :dequeue)))) 19 | (should (= 0 (@! q :size))))) 20 | 21 | (ert-deftest @queue-stack () 22 | (let ((q (@extend @queue @stack))) 23 | (@! q :enqueue 'b) 24 | (should (eq 'b (@! q :peek))) 25 | (@! q :enqueue 'c) 26 | (@! q :push 'a) 27 | (should (= 3 (@! q :size))) 28 | (should 29 | (equal '(a b c) 30 | (@! q :to-list))))) 31 | -------------------------------------------------------------------------------- /lib/@stack.el: -------------------------------------------------------------------------------- 1 | ;;; @stack.el --- stack prototype written in @ -*- lexical-binding: t; -*- 2 | 3 | (require '@) 4 | (require 'cl-lib) 5 | 6 | (with-no-warnings 7 | (defvar @stack (@extend :head ()) 8 | "A stack with access provided only to the top of the stack.")) 9 | 10 | (def@ @stack :size () 11 | "Return the number of elements in this stack." 12 | (length @:head)) 13 | 14 | (def@ @stack :emptyp () 15 | "Return t if the stack is empty." 16 | (null @:head)) 17 | 18 | (def@ @stack :push (element) 19 | "Push ELEMENT onto the stack, returning the stack." 20 | (prog1 @@ 21 | (push element @:head))) 22 | 23 | (def@ @stack :pop () 24 | "Pop the top element from this stack, returning it." 25 | (pop @:head)) 26 | 27 | (def@ @stack :peek () 28 | "Return the first element of this stack without removing it." 29 | (car @:head)) 30 | 31 | (def@ @stack :clone () 32 | "Return a shallow copy of this stack." 33 | (@extend @@ :head @:head)) 34 | 35 | (def@ @stack :to-list () 36 | "Return this entire stack as a list." 37 | (cl-copy-list @:head)) 38 | 39 | (provide '@stack) 40 | 41 | ;;; @stack.el ends here 42 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .POSIX: 2 | EMACS = emacs 3 | 4 | elc = @.elc \ 5 | @-mixins.elc \ 6 | lib/@heap.elc \ 7 | lib/@queue.elc \ 8 | lib/@stack.elc \ 9 | lib/@vector.elc 10 | test = @-tests.elc \ 11 | lib/@heap-tests.elc \ 12 | lib/@queue-tests.elc \ 13 | lib/@stack-tests.elc \ 14 | lib/@vector-tests.elc 15 | 16 | compile: $(elc) 17 | 18 | check: test 19 | test: $(test) 20 | $(EMACS) -batch -Q -L . -L lib/ \ 21 | -l @-tests.elc \ 22 | -l lib/@heap-tests.elc \ 23 | -l lib/@queue-tests.elc \ 24 | -l lib/@stack-tests.elc \ 25 | -l lib/@vector-tests.elc \ 26 | -f ert-run-tests-batch 27 | 28 | @-mixins.elc: @-mixins.el @.elc 29 | lib/@heap.elc: lib/@heap.el lib/@vector.elc @.elc 30 | lib/@queue.elc: lib/@queue.el @.elc 31 | lib/@stack.elc: lib/@stack.el @.elc 32 | lib/@vector.elc: lib/@vector.el @.elc 33 | @-tests.elc: @-tests.el @.elc 34 | lib/@heap-tests.elc: lib/@heap-tests.el lib/@heap.elc 35 | lib/@queue-tests.elc: lib/@queue-tests.el lib/@queue.elc lib/@stack.elc 36 | lib/@stack-tests.elc: lib/@stack-tests.el lib/@stack.elc 37 | lib/@vector-tests.elc: lib/@vector-tests.el lib/@vector.elc 38 | 39 | clean: 40 | rm -f $(elc) $(test) 41 | 42 | .SUFFIXES: .el .elc 43 | .el.elc: 44 | $(EMACS) -batch -Q -L . -L lib/ -f batch-byte-compile $< 45 | -------------------------------------------------------------------------------- /lib/@queue.el: -------------------------------------------------------------------------------- 1 | ;;; @queue.el --- queue prototype written in @ 2 | 3 | (require '@) 4 | (require 'cl-lib) 5 | 6 | (with-no-warnings 7 | (defvar @queue (@extend :head nil :tail nil) 8 | "A queue, restricted to appending to the back and retrieving from the front. 9 | This prototype can be mixed with @stack for pushing onto the front.")) 10 | 11 | (def@ @queue :size () 12 | "Return the number of elements in this queue." 13 | (length @:head)) 14 | 15 | (def@ @queue :emptyp () 16 | "Return t if this queue is empty." 17 | (null @:head)) 18 | 19 | (def@ @queue :enqueue (element) 20 | "Add ELEMENT to the end of this queue. Return this queue." 21 | (prog1 @@ 22 | (if (@:emptyp) 23 | (setf @:head (list element) 24 | @:tail @:head) 25 | (setf (cdr @:tail) (list element) 26 | @:tail (cdr @:tail))))) 27 | 28 | (def@ @queue :dequeue () 29 | "Remove and return element at the front of this queue." 30 | (prog1 (pop @:head) 31 | (when (@:emptyp) 32 | (setf @:tail nil)))) 33 | 34 | (def@ @queue :peek () 35 | "Return the element at the front of the queue without returning it." 36 | (car @:head)) 37 | 38 | (def@ @queue :clone () 39 | "Return a shallow copy of this queue." 40 | (let ((new-head (cl-copy-seq @:head))) 41 | (@extend @@ :head new-head :tail (last new-head)))) 42 | 43 | (def@ @queue :to-list () 44 | "Return this entire queue as a list." 45 | (cl-copy-list @:head)) 46 | 47 | (provide '@queue) 48 | 49 | ;;; @queue.el ends here 50 | -------------------------------------------------------------------------------- /@-mixins.el: -------------------------------------------------------------------------------- 1 | ;;; @-mixins.el --- useful mixin prototypes for @ -*- lexical-binding: t; -*- 2 | 3 | ;; This is free and unencumbered software released into the public domain. 4 | 5 | ;;; Commentary: 6 | 7 | ;; The mixins provided: 8 | 9 | ;; * @soft-get 10 | ;; * @immutable 11 | ;; * @watchable 12 | 13 | ;; See each variable's documentation for more info. 14 | 15 | ;;; Code: 16 | 17 | (require '@) 18 | 19 | (defvar @soft-get (@extend :default-get nil) 20 | "Mixin: don't throw errors on unbound properties.") 21 | 22 | (def@ @soft-get :get (_property) 23 | "If no DEFAULT is provided for PROPERTY, return @:default-get." 24 | @:default-get) 25 | 26 | (with-no-warnings 27 | (defvar @immutable (@extend :immutable-error t) 28 | "Don't allow changes on this object. 29 | Causes error if :immutable-error is t.")) 30 | 31 | (def@ @immutable :set (property _value) 32 | "Don't allow setting of properties on this object." 33 | (when @:immutable-error 34 | (error "Object is immutable, cannot set %s" property))) 35 | 36 | (with-no-warnings 37 | (defvar @watchable (@extend :watchers nil) 38 | "Allow subscribing to changes to this object.")) 39 | 40 | (def@ @watchable :watch (callback) 41 | "Subscribe to this object's changes." 42 | (push callback @:watchers)) 43 | 44 | (def@ @watchable :unwatch (callback) 45 | "Subscribe to this object's changes." 46 | (setf @:watchers (remove callback @:watchers))) 47 | 48 | (def@ @watchable :set (property new) 49 | (dolist (callback @:watchers) 50 | (funcall callback @@ property new)) 51 | (@^:set property new)) 52 | 53 | (provide '@-mixins) 54 | 55 | ;;; @-mixins.el ends here 56 | -------------------------------------------------------------------------------- /@-tests.el: -------------------------------------------------------------------------------- 1 | ;;; @-tests.el -*- lexical-binding: t; -*- 2 | 3 | (require '@) 4 | (require 'ert) 5 | 6 | (ert-deftest @-inheritance () 7 | "Tests prototype chain walking." 8 | (should 9 | (string= "left" 10 | (let* ((@root (@extend :name "root")) 11 | (@left (@extend @root :name "left")) 12 | (@right (@extend @root :name "right")) 13 | (@top (@extend @left @right))) 14 | (@ @top :name)))) 15 | (should 16 | (string= "right" 17 | (let* ((@root (@extend :name "root")) 18 | (@left (@extend @root)) 19 | (@right (@extend @root :name "right")) 20 | (@top (@extend @left @right))) 21 | (@ @top :name)))) 22 | (should 23 | (string= "root" 24 | (let* ((@root (@extend :name "root")) 25 | (@left (@extend @root)) 26 | (@right (@extend @root)) 27 | (@top (@extend @left @right))) 28 | (@ @top :name))))) 29 | 30 | (ert-deftest @-super () 31 | (let* ((a (@extend :foo :a)) 32 | (b (@extend a :foo :b))) 33 | (should (eq :b (@ b :foo))) 34 | (should (eq :a (@ b :foo :super 1))))) 35 | 36 | (ert-deftest @-setf () 37 | (let ((a (@extend :foo :before))) 38 | (should (eq :before (@ a :foo))) 39 | (setf (@ a :foo) :after) 40 | (should (eq :after (@ a :foo))))) 41 | 42 | (ert-deftest @-instance-of () 43 | "Tests the @is function." 44 | (should (@is (@extend) @)) 45 | (should (@is (@extend (@extend)) @)) 46 | (should-not (@is @ (@extend))) 47 | (should-not (@is t @)) 48 | (should-not (@is @ t))) 49 | 50 | (ert-deftest @-method () 51 | "Tests method calls." 52 | (should 53 | (string= 54 | "Hi, Foo" 55 | (let ((foo (@extend :greet (lambda (_ name) (concat "Hi, " name))))) 56 | (@! foo :greet "Foo"))))) 57 | 58 | (ert-deftest @-replace () 59 | "Tests the @: replacement walker." 60 | (should (equal (@--walk '(setf @:name 10) '(quote) #'@--replace) 61 | '(setf (@ @@ :name) 10))) 62 | (should (equal (@--walk '(setf '@:name 10) '(quote) #'@--replace) 63 | '(setf '@:name 10))) 64 | (should (eq :bar (with-@@ (@extend :foo :bar) @:foo))) 65 | (should (eq :bar 66 | (let* ((a (@extend :foo :bar)) 67 | (b (@extend a :foo :foo))) 68 | (with-@@ b 69 | @^:foo))))) 70 | 71 | ;;; @-tests.el ends here 72 | -------------------------------------------------------------------------------- /lib/@heap.el: -------------------------------------------------------------------------------- 1 | ;;; @heap.el --- binary heap prototype written in @ -*- lexical-binding: t; -*- 2 | 3 | (require '@) 4 | (require '@vector) 5 | (require 'cl-lib) 6 | 7 | (with-no-warnings 8 | (defvar @heap (@extend :vector nil :heap-key #'identity :heap-compare #'<) 9 | "A priority heap prototype with extendable key and compare functions.")) 10 | 11 | (def@ @heap :init (&optional key compare) 12 | (setf @:vector (@! @vector :new)) 13 | (when key (setf @:heap-key key)) 14 | (when compare (setf @:heap-compare key))) 15 | 16 | (def@ @heap :emptyp () 17 | "Return t if this heap is empty." 18 | (not (@ @:vector 0))) 19 | 20 | (def@ @heap :peek () 21 | "Return the next output element of the heap without removing it." 22 | (@ @:vector 0)) 23 | 24 | (def@ @heap :add (element) 25 | "Add ELEMENT to this heap with PRIORITY priority. Return this heap." 26 | (prog1 @@ 27 | (let* ((i (@! @:vector :size)) 28 | (parent (floor (1- i) 2)) 29 | (key @:heap-key) 30 | (compare @:heap-compare)) 31 | (@! @:vector :push element) 32 | (cl-flet ((compare (a b) 33 | (funcall compare (funcall key (@ @:vector a)) 34 | (funcall key (@ @:vector b))))) 35 | (while (and (>= parent 0) (compare i parent)) 36 | (@! @:vector :swap i parent) 37 | (setf i parent 38 | parent (floor (1- parent) 2))))))) 39 | 40 | (def@ @heap :next () 41 | "Remove and return the next element in the heap." 42 | (prog1 (@ @:vector 0) 43 | (let* ((replace (@! @:vector :pop))) 44 | (unless (@! @:vector :emptyp) 45 | (setf (@ @:vector 0) replace) 46 | (cl-loop with compare = @:heap-compare 47 | with key = @:heap-key 48 | for i = 0 then largest 49 | for a = (+ 1 (* i 2)) and b = (+ 2 (* i 2)) 50 | for na = (@ @:vector a) and nb = (@ @:vector b) 51 | for largest = 52 | (let ((largest i)) 53 | (if (and na (funcall compare (funcall key na) 54 | (funcall key (@ @:vector largest)))) 55 | (setf largest a)) 56 | (if (and nb (funcall compare (funcall key nb) 57 | (funcall key (@ @:vector largest)))) 58 | (setf largest b)) 59 | largest) 60 | while (not (= largest i)) 61 | do (@! @:vector :swap i largest)))))) 62 | 63 | (def@ @heap :clone () 64 | "Make a shallow copy of this heap." 65 | (@extend @@ :vector (@! @:vector :clone))) 66 | 67 | (def@ @heap :to-list () 68 | "Return the elements of this heap in order as a list." 69 | (let ((clone (@:clone))) 70 | (cl-loop until (@! clone :emptyp) collect (@! clone :next)))) 71 | 72 | (provide '@heap) 73 | 74 | ;;; @heap.el ends here 75 | -------------------------------------------------------------------------------- /lib/@vector.el: -------------------------------------------------------------------------------- 1 | ;;; @vector.el --- vector prototype written in @ -*- lexical-binding: t; -*- 2 | 3 | (require '@) 4 | (require 'cl-lib) 5 | 6 | (with-no-warnings 7 | (defvar @vector (@extend :vector [] :fill 0 :infinite t :vector-default nil) 8 | "A dynamically growing vector with constant-time element 9 | access. If :infinite is t then array access is unbounded to the 10 | right (i.e. all non-negative accesses are valid).")) 11 | 12 | (def@ @vector :init (&rest elements) 13 | "Initialize vector with ELEMENTS." 14 | (@^:init) 15 | (setf @:vector (cl-coerce elements 'vector) 16 | @:fill (length elements))) 17 | 18 | (def@ @vector :size () 19 | "Return the number of elements in this vector." 20 | @:fill) 21 | 22 | (def@ @vector :capacity () 23 | "Return the current capacity of this vector." 24 | (length @:vector)) 25 | 26 | (def@ @vector :emptyp () 27 | "Return t if this vector is empty." 28 | (= @:fill 0)) 29 | 30 | (def@ @vector :grow (&optional (factor 2)) 31 | "Increase the capacity of this vector by FACTOR." 32 | (prog1 @@ 33 | (let* ((new-length (max 1 (ceiling (* factor (length @:vector))))) 34 | (vec (make-vector new-length @:vector-default))) 35 | (cl-loop for element across @:vector 36 | for i upfrom 0 37 | do (setf (aref vec i) element)) 38 | (setf @:vector vec)))) 39 | 40 | (def@ @vector :trim () 41 | "Free any extra space claimed by this vector." 42 | (setf @:vector (cl-subseq @:vector 0 @:fill))) 43 | 44 | (def@ @vector :push (&rest elements) 45 | "Append ELEMENTS to the end of this vector." 46 | (prog1 @@ 47 | (let ((count (length elements))) 48 | (while (< (- (length @:vector) @:fill) count) 49 | (@:grow))) 50 | (dolist (element elements) 51 | (setf (aref @:vector @:fill) element) 52 | (cl-incf @:fill)))) 53 | 54 | (def@ @vector :pop () 55 | "Remove the element from the end of this vector and return it." 56 | (when (> @:fill 0) 57 | (prog1 (aref @:vector (cl-decf @:fill)) 58 | (setf (aref @:vector @:fill) nil)))) 59 | 60 | (def@ @vector :shift () 61 | "Remove element from the front of this vector (slow)." 62 | (unless (@:emptyp) 63 | (prog1 (@ @@ 0) 64 | (setf @:vector (cl-subseq @:vector 1)) 65 | (cl-decf @:fill)))) 66 | 67 | (def@ @vector :unshift (&rest elements) 68 | "Add elements from to the front of this vector (slow), returning this." 69 | (prog1 @@ 70 | (setf @:vector (cl-concatenate 'vector elements @:vector)) 71 | (cl-incf @:fill (length elements)))) 72 | 73 | (def@ @vector :swap (i j) 74 | "Swap elements I and J in this vector, returning this vector." 75 | (prog1 @@ 76 | (unless (= i j) 77 | (cl-psetf (@ @@ i) (@ @@ j) 78 | (@ @@ j) (@ @@ i))))) 79 | 80 | (def@ @vector :to-list () 81 | "Return the contents of this vector as a list." 82 | (cl-coerce (cl-subseq @:vector 0 @:fill) 'list)) 83 | 84 | (def@ @vector :clone () 85 | "Make a shallow copy of this vector." 86 | (@extend @@ :vector (cl-copy-seq @:vector) :fill @:fill 87 | :infinite @:infinite :vector-default @:vector-default)) 88 | 89 | (def@ @vector :get (n) 90 | "Dynamic getter: get Nth element from this vector." 91 | (if (not (integerp n)) 92 | (@^:get n) 93 | (if (< n @:fill) 94 | (aref @:vector n) 95 | (if @:infinite 96 | @:vector-default 97 | (signal 'args-out-of-range (list (cl-subseq @:vector 0 @:fill) n)))))) 98 | 99 | (def@ @vector :set (n value) 100 | "If N is an integer, sets the index in the vector to VALUE." 101 | (if (not (integerp n)) 102 | (@^:set n value) 103 | (while (>= n (length @:vector)) 104 | (@:grow)) 105 | (setf (aref @:vector n) value 106 | @:fill (max (1+ n) @:fill)))) 107 | 108 | (provide '@vector) 109 | 110 | ;;; @vector.el ends here 111 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # @, another object system for Emacs Lisp 2 | 3 | @ is a library providing a domain-specific language for 4 | multiple-inheritance prototype-based objects in Emacs Lisp. The goal 5 | is to provide a platform for elegant object-oriented Emacs Lisp. 6 | 7 | The root object of the @ object system is `@`. New objects are created 8 | with the `@extend` function, by extending existing objects. Given no 9 | objects to extend, new objects will implicitly extend `@`. Keyword 10 | arguments provided to `@extend` are assigned as properties on the new 11 | object. 12 | 13 | Properties are looked up using `eq`, so stick to keywords, symbols, 14 | and integers as property keys. The parent prototypes of an object, 15 | used in property lookups, are listed in the `:proto` property of the 16 | object. This can be modified at any time to change the prototype 17 | chain. 18 | 19 | See also: [Prototype-based Elisp Objects with @](http://nullprogram.com/blog/2013/04/07/) 20 | 21 | ## Prototype Library 22 | 23 | Practical example @ prototypes can be found under lib/. When 24 | prototypes are stored in global variables following the @ naming 25 | convention, as demonstrated in the examples, their methods can be 26 | looked up with `describe-@` (C-h @), similar to 27 | `describe-function` (C-h f). 28 | 29 | ## Feature Demonstration 30 | 31 | Here's a hands-on example of @'s features. 32 | 33 | ### Property Access 34 | 35 | ```el 36 | (require '@) 37 | 38 | ;; Create a rectangle prototype, extending the root object @. 39 | ;; Convention: prefix "class" variable names with @. 40 | (defvar @rectangle (@extend :width nil :height nil)) 41 | 42 | ;; The @ function is used to access properties of an object, following 43 | ;; the prototype chain breadth-first as necessary. An error is thrown 44 | ;; if the property has not been defined. 45 | (@ @rectangle :width) ; => nil 46 | 47 | ;; The @ function is setf-able. Assignment *always* happens on the 48 | ;; immediate object, never on a parent prototype. 49 | (setf (@ @rectangle :width) 0) 50 | (setf (@ @rectangle :height) 0) 51 | 52 | ;; Define the method :area on @rectangle. 53 | ;; The first argument is this/self. Convention: call it @@. 54 | (setf (@ @rectangle :area) (lambda (@@) (* (@ @@ :width) (@ @@ :height)))) 55 | 56 | ;; Convenience macro def@ for writing methods. Symbols like @: will be 57 | ;; replaced by lookups on @@. The following is equivalent to the above 58 | ;; definition. 59 | (def@ @rectangle :area () 60 | (* @:width @:height)) 61 | ``` 62 | 63 | ### Multiple Inheritance 64 | 65 | ```el 66 | ;; Create a color mix-in prototype 67 | (defvar @colored (@extend :color (list))) 68 | 69 | ;; The @: variables are setf-able, too. 70 | (def@ @colored :mix (color) 71 | (push color @:color)) 72 | 73 | ;; Create a colored rectangle from the prototypes. 74 | (defvar foo (@extend @colored @rectangle :width 10 :height 4)) 75 | 76 | ;; @! is used to call methods. The object itself is passed as the 77 | ;; first argument to the function stored on that prototype's property. 78 | (@! foo :area) ; => 40 79 | (@! foo :mix :red) 80 | (@! foo :mix :blue) 81 | (@ foo :color) ; => (:blue :red) 82 | 83 | ;; @: variables are turned into method calls when in function position. 84 | (def@ foo :describe () 85 | (format "{color: %s, area: %d}" @:color (@:area))) 86 | 87 | (@! foo :describe) ; => "{color: (:blue :red), area: 40}" 88 | ``` 89 | 90 | ### Constructors and Super Methods 91 | 92 | ```el 93 | ;; By convention, constructors are the :init method. The @^: 94 | ;; "variables" are used to access super methods, including :init. Use 95 | ;; this to chain constructors and methods up the prototype chain (like 96 | ;; CLOS's `call-next-method'). 97 | (def@ @rectangle :init (width height) 98 | (@^:init) 99 | (setf @:width width @:height height)) 100 | 101 | ;; The :new method on @ extends @@ with a new object and calls :init 102 | ;; on it with the provided arguments. 103 | (@! (@! @rectangle :new 13.2 2.1) :area) ; => 27.72 104 | ``` 105 | 106 | ### Dynamic Property Getters and Setters 107 | 108 | ```el 109 | ;; If a property is not found in the prototype chain, the :get method 110 | ;; is used to determine the value. 111 | (let ((obj (@extend))) 112 | (def@ obj :get (property) 113 | (format "got %s" property)) 114 | (@ obj :foo)) 115 | ; => "got :foo" 116 | 117 | ;; The :get method on @, the default getter, produces an error if a 118 | ;; property is unbound. If you would rather unbound properties return 119 | ;; nil mix in @soft-get, which provides an alternate default :get 120 | ;; method. 121 | (@ (@extend @rectangle @soft-get) :foo) ; => nil 122 | 123 | ;; Properties are assigned using the :set method. The :set method on @ 124 | ;; does standard property assignment as would be expected. This can be 125 | ;; overridden for custom assignment behavior. 126 | (let ((foo-only (@extend))) 127 | (def@ foo-only :set (property value) 128 | (if (string-match-p "^:foo" (prin1-to-string property)) 129 | (@^:set property value) ; supermethod 130 | (error "Only :foo* properties allowed!"))) 131 | (setf (@ foo-only :foo-bar) 'a) ; ok 132 | (setf (@ foo-only :bar) 'b)) ; ERROR 133 | 134 | ;; Using this, an @immutable prototype mixin is provided that 135 | ;; disallows all property assignments. 136 | (setf (@ (@extend @immutable) :foo) 'a) ; ERROR 137 | ``` 138 | 139 | The @vector prototype under lib/ shows how these can be useful for 140 | providing pseudo-properties. 141 | 142 | ```el 143 | ;; Built on :set, a @watchable mixin is provided for observing all of 144 | ;; the changes to any object. 145 | (let ((history ()) 146 | (obj (@extend @watchable))) 147 | (@! obj :watch (lambda (obj prop new) (push (list property new) history))) 148 | (setf (@ obj :foo) 0) 149 | (setf (@ obj :foo) 1) 150 | (setf (@ obj :bar) 'a) 151 | (setf (@ obj :bar) 'b) 152 | history) 153 | ; => ((:bar b) (:bar a) (:foo 1) (:foo 0)) 154 | ``` 155 | 156 | ### Reflection 157 | 158 | ```el 159 | ;; @is is the classical "instanceof" operator. It works on any type of 160 | ;; object in both positions. 161 | (@is foo @colored) ; => t 162 | (@is foo @rectangle) ; => t 163 | (@is foo foo) ; => t 164 | (@is foo @) ; => t 165 | (@is foo (@extend)) ; => nil 166 | (@is [1 2 3] @) ; => nil 167 | 168 | ;; The :is method on @ can also be used for this. 169 | (@! @colored :is @) ; => t 170 | (@! foo :is @colored) ; => t 171 | 172 | ;; The :keys method on @ can be used to list the keys on an object. 173 | (@! foo :keys) ; => (:proto :width :height :color) 174 | ``` 175 | 176 | ### Syntax Highlighting 177 | 178 | The library provides syntax highlighting for 'def@' and '@:' variables 179 | in emacs-lisp-mode, so the above @ uses will look more official in an 180 | Emacs buffer. 181 | -------------------------------------------------------------------------------- /@.el: -------------------------------------------------------------------------------- 1 | ;;; @.el --- multiple-inheritance prototype-based objects DSL -*- lexical-binding: t; -*- 2 | 3 | ;; This is free and unencumbered software released into the public domain. 4 | 5 | ;; Author: Christopher Wellons 6 | ;; URL: https://github.com/skeeto/at-el 7 | ;; Version: 1.5 8 | ;; Package-Requires: ((emacs "24.3")) 9 | 10 | ;;; Commentary: 11 | 12 | ;; @ is a library providing a domain-specific language for 13 | ;; multiple-inheritance prototype-based objects in Emacs Lisp. The 14 | ;; goal is to provide a platform for elegant object-oriented Emacs 15 | ;; Lisp. 16 | 17 | ;; @ performance benefits significantly from byte-compilation. 18 | 19 | ;; See README.md for a demonstration. 20 | 21 | ;;; Code: 22 | 23 | (require 'gv) 24 | (require 'cl-lib) 25 | 26 | (with-no-warnings 27 | (defvar @ [@ (:proto ())] 28 | "The root object of the @ object system.")) 29 | 30 | (defun @p (object) 31 | "Return t if OBJECT is an @ object." 32 | (and (vectorp object) (eq '@ (aref object 0)))) 33 | 34 | (defun @extend (&rest args) 35 | "Create a new object extending zero or more prototypes, binding 36 | the given property/value pairs as properties. If no prototypes 37 | are provided, extend @." 38 | (let* ((objects ())) 39 | (while (@p (car args)) 40 | (push (pop args) objects)) 41 | (when (null objects) (push @ objects)) 42 | (vector '@ `(:proto ,(nreverse objects) ,@args)))) 43 | 44 | (defun @precedence (object) 45 | "Return the lookup precedence order for OBJECT." 46 | (cl-remove-duplicates 47 | (append (plist-get (aref object 1) :proto) 48 | (cl-mapcan #'@precedence (plist-get (aref object 1) :proto))))) 49 | 50 | (defun @is (object proto) 51 | "Return t if OBJECT is an instance of PROTO." 52 | (and (@p object) 53 | (or (eq object proto) 54 | (and (memq proto (@precedence object)) t)))) 55 | 56 | (defsubst @--queue-create () 57 | "Create a new empty queue object." 58 | (cons nil nil)) 59 | 60 | (defsubst @--queue-head (queue) 61 | "Return the head of QUEUE without modification." 62 | (car queue)) 63 | 64 | (defun @--queue-enqueue (queue value) 65 | "Add VALUE to the end of QUEUE." 66 | (let ((new (cons value nil))) 67 | (prog1 value 68 | (if (cdr queue) 69 | (setf (cdr (cdr queue)) new) 70 | (setf (car queue) new)) 71 | (setf (cdr queue) new)))) 72 | 73 | (defun @--queue-dequeue (queue) 74 | "Remove and return the front of QUEUE." 75 | (if (eq (car queue) (cdr queue)) 76 | (prog1 (caar queue) 77 | (setf (car queue) nil 78 | (cdr queue) nil)) 79 | (pop (car queue)))) 80 | 81 | (cl-defun @ (object property &key (super 0) (default nil defaulted)) 82 | "Find and return PROPERTY for OBJECT in the prototype chain. 83 | 84 | If :super is t, skip the first match in the prototype chain. 85 | If :default, don't produce an error but return the provided value." 86 | (let ((queue (@--queue-create))) 87 | (@--queue-enqueue queue object) 88 | (cl-loop while (@--queue-head queue) 89 | with skip = super 90 | for plist = (aref (@--queue-dequeue queue) 1) 91 | for pair = (plist-member plist property) 92 | when pair do (if (zerop skip) 93 | (cl-return (cl-second pair)) 94 | (cl-decf skip)) 95 | do (dolist (parent (plist-get plist :proto)) 96 | (@--queue-enqueue queue parent)) 97 | finally return 98 | (if defaulted 99 | default 100 | (@! object :get property))))) 101 | 102 | (defvar @--super 0 103 | "Dynamic variablee to trace super method call or super property access.") 104 | (cl-defun @--super (object property &key (default nil defaulted)) 105 | (let ((@--super (+ 1 @--super))) 106 | (@ object property :super @--super :default default))) 107 | 108 | (defun @--set (object property new-value) 109 | "Set the PROPERTY of OBJECT to NEW-VALUE." 110 | (@! object :set property new-value)) 111 | 112 | (gv-define-simple-setter @ @--set) 113 | 114 | (defun @! (object property &rest args) 115 | "Call the method stored in PROPERTY with ARGS." 116 | (apply (@ object property) object args)) 117 | 118 | (defun @--super! (object property &rest args) 119 | "Call the method stored in PROPERTY with ARGS." 120 | (let ((@--super (+ 1 @--super))) 121 | (apply (@ object property :super @--super) object args))) 122 | 123 | (cl-eval-when (compile load eval) 124 | (defun @--walk (sexp skip replace &optional head) 125 | "Replace all symbols by calling REPLACE on them." 126 | (cl-macrolet ((wrap (exp) `(let ((v ,exp)) (if head (list v) v)))) 127 | (cond 128 | ((symbolp sexp) (funcall replace sexp head)) 129 | ((atom sexp) (wrap sexp)) 130 | ((member (cl-first sexp) skip) (wrap sexp)) 131 | ((wrap 132 | (append (@--walk (cl-first sexp) skip replace t) 133 | (cl-loop for element in (cdr sexp) 134 | collect (@--walk element skip replace nil))))))))) 135 | 136 | (cl-eval-when (compile load eval) 137 | (defun @--replace (symbol head) 138 | "Replace @: and @^: symbols with their lookup/funcall expansions." 139 | (let ((name (symbol-name symbol))) 140 | (cond ((string-prefix-p "@:" name) 141 | (let ((property (intern (substring name 1)))) 142 | (if head 143 | `(@! @@ ,property) 144 | `(@ @@ ,property)))) 145 | ((string-prefix-p "@^:" name) 146 | (let ((property (intern (substring name 2)))) 147 | (if head 148 | `(@--super! @@ ,property) 149 | `(@--super @@ ,property)))) 150 | (t (if head (list symbol) symbol)))))) 151 | 152 | (defmacro with-@@ (object &rest body) 153 | "Provide the @: and @^: DSL utilities for OBJECT in BODY." 154 | (declare (indent defun)) 155 | `(let ((@@ ,object)) 156 | ,@(cdr (@--walk (cons 'progn body) '(quote with-@@) #'@--replace)))) 157 | 158 | (defmacro def@ (object method params &rest body) 159 | "Define METHOD body on OBJECT." 160 | (declare (indent defun)) 161 | `(progn 162 | (setf (@ ,object ,method) 163 | (cl-function 164 | (lambda ,(cons '@@ params) 165 | ,@(if (stringp (car body)) (list (car body)) ()) 166 | (with-@@ @@ 167 | (ignore @@) 168 | ,@(if (stringp (car body)) (cdr body) body))))) 169 | ,method)) 170 | 171 | (font-lock-add-keywords 'emacs-lisp-mode 172 | ;; "(\\<\\(def@\\)\\> +\\([^ ()]+\\)" 173 | '(("(\\<\\(def@\\) +\\([^ ()]+\\)" 174 | (1 'font-lock-keyword-face) 175 | (2 'font-lock-function-name-face)))) 176 | 177 | (font-lock-add-keywords 'emacs-lisp-mode 178 | ;; "\\<\\(@\\^?:[^ ()]+\\)\\>" 179 | '(("\\(@\\^?:[^ ()]+\\)\\>" 180 | (1 'font-lock-builtin-face)))) 181 | 182 | ;; Core methods 183 | 184 | (setf (aref @ 1) ; Bootstrap :set 185 | (plist-put (aref @ 1) :set 186 | (lambda (@@ property new-value) 187 | (setf (aref @@ 1) 188 | (plist-put (aref @@ 1) property new-value)) 189 | new-value))) 190 | 191 | (def@ @ :get (property) 192 | "Dynamic property getter. This one produces an error." 193 | (error "Property unbound: %s" property)) 194 | 195 | (def@ @ :init ()) 196 | 197 | (def@ @ :new (&rest args) 198 | "Extend this object and call the constructor method (:init) with ARGS." 199 | (let ((object (@extend @@))) 200 | (apply (@ object :init) object args) 201 | object)) 202 | 203 | (def@ @ :is (object) 204 | "Return t if this object is an instance of OBJECT." 205 | (@is @@ object)) 206 | 207 | (def@ @ :keys () 208 | "Return a list of the keys directly on @@." 209 | (cl-loop for (key _) on (aref @@ 1) by #'cddr collect key)) 210 | 211 | ;; Top-level Object Management 212 | 213 | (defun @--list-all () 214 | "List all global prototypes that start with @." 215 | (cl-flet ((protop (atom) (and (boundp atom) 216 | (@p (symbol-value atom)) 217 | (= ?@ (aref (symbol-name atom) 0))))) 218 | (let ((list)) 219 | (mapatoms (lambda (atom) (if (protop atom) (push atom list)))) 220 | list))) 221 | 222 | (defun describe-@ (proto property) 223 | "Like `describe-function' but for global protoype methods." 224 | (interactive 225 | (let* ((protos (mapcar #'symbol-name (@--list-all))) 226 | (prompt0 "Describe prototype: ") 227 | (symbol (intern (completing-read prompt0 protos nil t "@"))) 228 | (proto (symbol-value symbol)) 229 | (props (@! proto :keys)) 230 | (methods (cl-remove-if-not 231 | (lambda (p) (functionp (@ proto p))) props)) 232 | (method-names (mapcar #'symbol-name methods)) 233 | (prompt1 "Describe property: ") 234 | (property (intern (completing-read prompt1 method-names nil t ":")))) 235 | (list proto property))) 236 | (describe-function (@ proto property))) 237 | 238 | (global-set-key (kbd "C-h @") 'describe-@) 239 | 240 | (defun @--undefine-all () 241 | "Undefine all public prototypes. Useful for reloading when debugging." 242 | (interactive) 243 | (mapc #'makunbound (@--list-all))) 244 | 245 | (defun @--byte-compile-all () 246 | "Byte-compile all public prototype methods." 247 | (interactive) 248 | (dolist (proto (mapcar #'symbol-value (@--list-all))) 249 | (dolist (prop (@! proto :keys)) 250 | (when (functionp (@ proto prop)) 251 | (byte-compile (@ proto prop)))))) 252 | 253 | (provide '@) 254 | 255 | ;;; @.el ends here 256 | --------------------------------------------------------------------------------