├── .gitignore ├── circle.yml ├── defclass-std-test.asd ├── defclass-std.asd ├── .travis.yml ├── src └── defclass-std.lisp ├── t └── defclass-std.lisp └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | dependencies: 2 | cache_directories: 3 | - ~/lisp 4 | pre: 5 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh; 6 | - case $CIRCLE_NODE_INDEX in 7 | 0) ros config set default.lisp sbcl-bin ;; 8 | 1) ros install ccl-bin; 9 | ros config set default.lisp ccl-bin ;; 10 | esac 11 | - ros run -- --version 12 | 13 | test: 14 | override: 15 | - ros -s prove -e '(or (prove:run :defclass-std-test) (uiop:quit -1))': {parallel: true} 16 | -------------------------------------------------------------------------------- /defclass-std-test.asd: -------------------------------------------------------------------------------- 1 | (defsystem defclass-std-test 2 | :name "defclass-std-test" 3 | :version "0.1.1" 4 | :author "André Miranda" 5 | :maintainer "André Miranda" 6 | :mailto "andremiramor@gmail.com" 7 | :homepage "https://github.com/EuAndreh/defclass-std" 8 | :bug-tracker "https://github.com/EuAndreh/defclass-std/issues" 9 | :source-control (:git "git@github.com:EuAndreh/defclass-std.git") 10 | :license "LLGPL" 11 | :description "Test system for defclass-std." 12 | :depends-on (defclass-std 13 | prove) 14 | :components ((:module "t" 15 | :components ((:test-file "defclass-std")))) 16 | :defsystem-depends-on (:prove-asdf) 17 | :perform (test-op :after (op c) 18 | (funcall (intern "RUN-TEST-SYSTEM" :prove-asdf) c) 19 | (asdf:clear-system c))) 20 | -------------------------------------------------------------------------------- /defclass-std.asd: -------------------------------------------------------------------------------- 1 | (defsystem defclass-std 2 | :name "defclass-std" 3 | :version "0.1.1" 4 | :author "André Miranda" 5 | :maintainer "André Miranda" 6 | :mailto "andremiramor@gmail.com" 7 | :homepage "https://github.com/EuAndreh/defclass-std" 8 | :bug-tracker "https://github.com/EuAndreh/defclass-std/issues" 9 | :source-control (:git "git@github.com:EuAndreh/defclass-std.git") 10 | :license "LLGPL" 11 | :depends-on (alexandria 12 | anaphora) 13 | :components ((:module "src" 14 | :components ((:file "defclass-std"))) 15 | (:static-file "README.md")) 16 | :description "A shortcut macro to write DEFCLASS forms quickly." 17 | :long-description #.(uiop:read-file-string 18 | (uiop:subpathname *load-truename* "README.md")) 19 | :in-order-to ((test-op (test-op defclass-std-test)))) 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: required 3 | env: 4 | matrix: 5 | - LISP=abcl 6 | - LISP=sbcl COVERALLS=true 7 | - LISP=ccl 8 | - LISP=clisp 9 | - LISP=cmucl 10 | - LISP=ecl 11 | 12 | matrix: 13 | allow_failures: 14 | - env: LISP=abcl # JVM build goes wrong too many times 15 | - env: LISP=clisp # wait for cl-coveralls dependencies to support it 16 | - env: LISP=cmucl # wait for CIM to support it 17 | - env: LISP=ecl # wait for cl-coveralls dependencies to support it 18 | 19 | install: 20 | - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; 21 | 22 | script: 23 | - cl -l defclass-std -l prove -l cl-coveralls 24 | -e '(progn 25 | (setf prove:*debug-on-error* t 26 | *debugger-hook* (lambda (c h) 27 | (declare (ignore c h)) 28 | (uiop:quit -1))) 29 | (or (coveralls:with-coveralls (:exclude "t") 30 | (prove:run :defclass-std-test)) 31 | (uiop:quit -1)))' 32 | -------------------------------------------------------------------------------- /src/defclass-std.lisp: -------------------------------------------------------------------------------- 1 | (defpackage defclass-std 2 | (:use cl) 3 | (:import-from alexandria 4 | make-keyword 5 | flatten 6 | symbolicate) 7 | (:import-from anaphora 8 | aif 9 | it) 10 | (:export defclass/std 11 | *default-std* 12 | *with-prefix* 13 | class/std 14 | printing-unreadably) 15 | (:documentation "Main (and only) project package.")) 16 | (in-package defclass-std) 17 | 18 | (defparameter *fusioned-keyword-combinations* 19 | '(:ai :ar :aw :ia :ir :iw :ra :ri :rw :wa :wi :wr) 20 | "All possible combinations of :a, :i, :r and :w.") 21 | 22 | (defparameter *default-added-keywords* '(:a :i) 23 | "Default abbreviated keywords added when none is found.") 24 | 25 | (defparameter *fusionable-keywords* '(:a :i :w :r) 26 | "All abbreviated keywords that can be fusioned.") 27 | 28 | (defparameter *standalone-keywords* '(:a :i :w :r :static :with :with-prefix :@@)) 29 | 30 | (defparameter *paired-keywords* '(:std :unbound :doc :type)) 31 | 32 | (defparameter *default-std* t 33 | "Special var that changes the behaviour of the DEFCLASS/STD macro. If true, adds a :initform nil by default to every field, when unespecified. If false, adds nothing.") 34 | 35 | (defparameter *with-prefix* nil 36 | "Special var that changes the behaviour of the DEFCLASS/STD macro. If tru, adds the class name as a prefix to every accessor/reader/writer function. If false, without the :with/:with-prefix slot option, adds nothing.") 37 | 38 | (defun remove-all (els list) 39 | "Applies remove recursively. Serves as a version of apeWEOFJIAOPWEIF that keeps the original sequence in the same order." 40 | (if els 41 | (remove-all (cdr els) (remove (car els) list)) 42 | list)) 43 | 44 | (defun extract-slot-names (line) 45 | "Finds all slot names in the LINE." 46 | (if (and line 47 | (not (keywordp (car line)))) 48 | (cons (car line) 49 | (extract-slot-names (cdr line))))) 50 | 51 | (defun extract-unkown-keywords (line) 52 | "Finds pairs of unknown-keywords (and optional values) in LINE." 53 | (if line 54 | (let ((slot (car line))) 55 | (cond ((or (not (keywordp slot)) 56 | (member slot *standalone-keywords*)) 57 | (extract-unkown-keywords (cdr line))) 58 | ((member slot *paired-keywords*) 59 | (extract-unkown-keywords (cddr line))) 60 | ((or (member (second line) (append *standalone-keywords* 61 | *paired-keywords*)) 62 | (null (cdr line))) 63 | (cons (car line) 64 | (extract-unkown-keywords (cdr line)))) 65 | (t (append (subseq line 0 2) 66 | (extract-unkown-keywords (cddr line)))))))) 67 | 68 | (defun split-fusioned-keywords (line) 69 | "Splits the fusioned keyword option, if present." 70 | (aif (intersection line *fusioned-keyword-combinations*) 71 | (append (remove-all it line) 72 | (mapcar #'make-keyword 73 | (flatten (mapcar (lambda (fus-kw) 74 | (coerce (string fus-kw) 75 | 'list)) 76 | it)))) 77 | (if (intersection line *fusionable-keywords*) 78 | line 79 | (append line *default-added-keywords*)))) 80 | 81 | (defun check-for-repeated-keywords (line) 82 | "Verifies if keyword options were repeated. Mainly useful for avoiding things like (:A :AI) together, or (:R :W) instead of (:A)." 83 | (cond ((and (member :w line) 84 | (member :r line)) 85 | (error "Use :A (accessor) instead of :W (writer) and :R (reader) in: ~s" 86 | line)) 87 | ((and (member :w line) 88 | (member :a line)) 89 | (error ":W (writer) and :A (accessor) shouldn't be together in: ~s." 90 | line)) 91 | ((and (member :r line) 92 | (member :a line)) 93 | (error ":R (reader) and :A (accessor) shouldn't be together in: ~s." 94 | line)))) 95 | 96 | (defun replace-keywords (env line prefix) 97 | "Receives a list of slots with keywords and returns a list of lists. Each sublist is a single slot, with all the options appended at the end." 98 | (let ((type (aif (member :type line) (cadr it) t))) 99 | (mapcar (lambda (slot) 100 | (concatenate 'list 101 | (list slot) 102 | (if (member :a line) 103 | (list :accessor (symbolicate prefix slot))) 104 | (if (member :r line) 105 | (list :reader (symbolicate prefix slot))) 106 | (if (member :w line) 107 | (list :writer (symbolicate prefix slot))) 108 | (if (member :i line) 109 | (list :initarg (make-keyword slot))) 110 | (aif (member :std line) 111 | (if (eq (cadr it) :unbound) 112 | nil 113 | (list :initform (cadr it))) 114 | (if *default-std* 115 | (if (subtypep 'null type env) 116 | (list :initform nil)))) 117 | (if (or (member :@@ line) 118 | (member :static line)) 119 | (list :allocation :class)) 120 | (aif (member :doc line) 121 | (list :documentation (cadr it))) 122 | (aif (member :type line) 123 | (list :type (cadr it))) 124 | (extract-unkown-keywords line))) 125 | (extract-slot-names line)))) 126 | 127 | (defmacro defclass/std (name direct-superclasses direct-slots &rest options 128 | &environment env) 129 | "Shortcut macro to the DEFCLASS macro. See README for syntax and usage." 130 | `(defclass ,name ,direct-superclasses 131 | ,(process-slots env direct-slots name) 132 | ,@options)) 133 | 134 | (defun process-slots (env direct-slots classname) 135 | "Returns the expanded list of DIRECT-SLOTS." 136 | (let ((processed (mapcar (lambda (line) 137 | (let ((prefix (if (or (member :with-prefix line) 138 | (member :with line) 139 | *with-prefix*) 140 | (concatenate 'string (string classname) "-") 141 | "")) 142 | (split-kws-line (split-fusioned-keywords line))) 143 | (check-for-repeated-keywords split-kws-line) 144 | (replace-keywords env split-kws-line prefix))) 145 | direct-slots))) 146 | (reduce #'append processed))) 147 | 148 | (defmacro class/std (name &body defaulted-slots) 149 | "Shortcut macro to the DEFCLASS/STD macro." 150 | `(defclass/std ,name () 151 | ((,@defaulted-slots)))) 152 | 153 | (defmacro printing-unreadably (fields-list class-std-form 154 | &key (type t) (identity t)) 155 | "Automatically generates the unreadable printing boiler plate to print classes and its fields (from FIELDS-LIST)." 156 | (let ((g!stream (gensym "STREAM")) 157 | (name (cadr class-std-form))) 158 | `(progn ,class-std-form 159 | (defmethod print-object ((,name ,name) ,g!stream) 160 | (print-unreadable-object (,name ,g!stream 161 | :type ,type 162 | :identity ,identity) 163 | (format ,g!stream 164 | ,(format nil "~{~a: ~~s~^,~^ ~}" fields-list) 165 | ,@(mapcar (lambda (a1) 166 | `(,a1 ,name)) 167 | fields-list))))))) 168 | -------------------------------------------------------------------------------- /t/defclass-std.lisp: -------------------------------------------------------------------------------- 1 | (defpackage defclass-std-test 2 | (:use cl prove defclass-std)) 3 | (in-package defclass-std-test) 4 | 5 | ;; NOTE: To run this test file, execute `(asdf:test-system :defclass-std)' in your Lisp. 6 | 7 | (plan 9) 8 | 9 | (deftest class/std->defclass/std->defclass-expansion-test 10 | (is-expand (class/std stub slot1 slot2 slot3 slot4 slot5) 11 | (DEFCLASS/STD STUB () 12 | ((SLOT1 SLOT2 SLOT3 SLOT4 SLOT5))) 13 | "CLASS/STD expands correctly into DEFCLASS/STD.") 14 | (is-expand (DEFCLASS/STD STUB () 15 | ((SLOT1 SLOT2 SLOT3 SLOT4 SLOT5))) 16 | (DEFCLASS STUB () 17 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 18 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 19 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL) 20 | (SLOT4 :ACCESSOR SLOT4 :INITARG :SLOT4 :INITFORM NIL) 21 | (SLOT5 :ACCESSOR SLOT5 :INITARG :SLOT5 :INITFORM NIL))) 22 | "DEFCLASS/STD generated by CLASS/STD expands as expected to DEFCLASS.")) 23 | 24 | (deftest class/std->defclass/std->defclass-with-args-expansion-test 25 | (is-expand (class/std new-stub var1 var2 var3 var4 :with :std :unbound) 26 | (DEFCLASS/STD NEW-STUB () 27 | ((VAR1 VAR2 VAR3 VAR4 :WITH :STD :UNBOUND))) 28 | "CLASS/STD with :keyword options expand correctly into a DEFCLASS/STD form with the same :keyword options.") 29 | (is-expand (DEFCLASS/STD NEW-STUB () 30 | ((VAR1 VAR2 VAR3 VAR4 :WITH :STD :UNBOUND))) 31 | (DEFCLASS NEW-STUB () 32 | ((VAR1 :ACCESSOR NEW-STUB-VAR1 :INITARG :VAR1) 33 | (VAR2 :ACCESSOR NEW-STUB-VAR2 :INITARG :VAR2) 34 | (VAR3 :ACCESSOR NEW-STUB-VAR3 :INITARG :VAR3) 35 | (VAR4 :ACCESSOR NEW-STUB-VAR4 :INITARG :VAR4))) 36 | "DEFCLASS/STD with keyword options generated by CLASS/STD with :keyowrd options expands as expected to DEFCLASS.")) 37 | 38 | (deftest default-accessor-initarg 39 | (is-expand (DEFCLASS/STD STUB () 40 | ((SLOT1 SLOT2 SLOT3 SLOT4 SLOT5))) 41 | (DEFCLASS STUB () 42 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 43 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 44 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL) 45 | (SLOT4 :ACCESSOR SLOT4 :INITARG :SLOT4 :INITFORM NIL) 46 | (SLOT5 :ACCESSOR SLOT5 :INITARG :SLOT5 :INITFORM NIL))) 47 | "Defaults omitted args (:ai) works correctly.")) 48 | 49 | (deftest test-all-keyword-option 50 | (is-expand (defclass/std computer (gadget) 51 | ((screen mouse keyboard :a :type string :with) 52 | (bluetooth touchpad :wi :std :unbound) 53 | (speaker microphone :r) 54 | (place :@@ :with-prefix :doc "Where it is" :r) 55 | (owner :static :std "Me" :w))) 56 | (DEFCLASS COMPUTER (GADGET) 57 | ((SCREEN :ACCESSOR COMPUTER-SCREEN :INITFORM NIL :TYPE STRING) 58 | (MOUSE :ACCESSOR COMPUTER-MOUSE :INITFORM NIL :TYPE STRING) 59 | (KEYBOARD :ACCESSOR COMPUTER-KEYBOARD :INITFORM NIL :TYPE STRING) 60 | (BLUETOOTH :WRITER BLUETOOTH :INITARG :BLUETOOTH) 61 | (TOUCHPAD :WRITER TOUCHPAD :INITARG :TOUCHPAD) 62 | (SPEAKER :READER SPEAKER :INITFORM NIL) 63 | (MICROPHONE :READER MICROPHONE :INITFORM NIL) 64 | (PLACE :READER COMPUTER-PLACE :INITFORM NIL :ALLOCATION :CLASS 65 | :DOCUMENTATION "Where it is") 66 | (OWNER :WRITER OWNER :INITFORM "Me" :ALLOCATION :CLASS))))) 67 | 68 | (deftest test-*default-std*-binding 69 | (is-expand (defclass/std default () 70 | ((with-std))) 71 | (DEFCLASS DEFAULT () 72 | ((WITH-STD :ACCESSOR WITH-STD :INITARG :WITH-STD :INITFORM NIL))) 73 | "*DEFAULT-STD* defaults to T, adding :INITFORM NIL") 74 | (let (*default-std*) 75 | (is-expand (defclass/std default () 76 | ((with-std))) 77 | (DEFCLASS DEFAULT () 78 | ((WITH-STD :ACCESSOR WITH-STD :INITARG :WITH-STD))) 79 | "When bound to NIL, *DEFAULT-STD* changes the behaviour of DEFCLASS/STD correctly, avoidind the addition of :INITFORM NIL."))) 80 | 81 | (deftest test-*with-prefix*-binding 82 | (is-expand (defclass/std prefix () 83 | ((without-prefix))) 84 | (DEFCLASS PREFIX () 85 | ((WITHOUT-PREFIX :ACCESSOR WITHOUT-PREFIX 86 | :INITARG :WITHOUT-PREFIX 87 | :INITFORM NIL))) 88 | "*WITH-PREFIX* defaults to NIL, avoiding the addition of the class name as a prefix to the accessor.") 89 | (let ((*with-prefix* t)) 90 | (is-expand (defclass/std prefix () 91 | ((without-prefix :with))) 92 | (DEFCLASS PREFIX () 93 | ((WITHOUT-PREFIX :ACCESSOR PREFIX-WITHOUT-PREFIX 94 | :INITARG :WITHOUT-PREFIX 95 | :INITFORM NIL))) 96 | "When bound to T, *WITH-PREFIX* changes the behaviour of DEFCLASS/STD, add the class name as a prefix to the accessor."))) 97 | 98 | (deftest test-ignore-unknown-keywords 99 | (is-expand (defclass/std unknown () 100 | ((slot :unknown :keywords))) 101 | (DEFCLASS UNKNOWN () 102 | ((SLOT :ACCESSOR SLOT 103 | :INITARG :SLOT 104 | :INITFORM NIL 105 | :UNKNOWN :KEYWORDS))) 106 | "DEFCLASS/STD with unknown keywords/values pairs works as expected, keeping them as they are, when no other option is present.") 107 | (is-expand (defclass/std unknown () 108 | ((slot :wi :unknown keywords :and values))) 109 | (DEFCLASS UNKNOWN () 110 | ((SLOT :WRITER SLOT 111 | :INITARG :SLOT 112 | :INITFORM NIL 113 | :UNKNOWN KEYWORDS 114 | :AND VALUES))) 115 | "DEFCLASS/STD with unknown keywords/values pairs works as expected, keeping them as they are, when other options are present.") 116 | (is-expand (defclass/std unknown () 117 | ((slot :unknown keywords :without-values))) 118 | (DEFCLASS UNKNOWN () 119 | ((SLOT :ACCESSOR SLOT 120 | :INITARG :SLOT 121 | :INITFORM NIL 122 | :UNKNOWN KEYWORDS 123 | :WITHOUT-VALUES))) 124 | "DEFCLASS/STD with unknown keywords without values pairs works as expected, when no other option is present.") 125 | (is-expand (defclass/std unknown () 126 | ((slot :a :unknown keywords :without-values))) 127 | (DEFCLASS UNKNOWN () 128 | ((SLOT :ACCESSOR SLOT 129 | :INITFORM NIL 130 | :UNKNOWN KEYWORDS 131 | :WITHOUT-VALUES))) 132 | "DEFCLASS/STD with unknown keywords without values pairs works as expected, when other options are present.")) 133 | 134 | (deftest printing-unreadably-form-expansion-test 135 | (is-expand (printing-unreadably (id name) (class/std employee name id salary)) 136 | (progn 137 | (class/std employee 138 | name 139 | id 140 | salary) 141 | (defmethod print-object ((employee employee) $stream) 142 | (print-unreadable-object (employee $stream :type t :identity t) 143 | (format $STREAM "ID: ~s, NAME: ~s" 144 | (id employee) (name employee))))))) 145 | 146 | (deftest repeated-keywords-errors-test 147 | (is-error (macroexpand-1 148 | '(defclass/std class1 () 149 | ((field :wr)))) 150 | 'simple-error 151 | ":WR throws error.") 152 | (is-error (macroexpand-1 153 | '(defclass/std class2 () 154 | ((field :wa)))) 155 | 'simple-error 156 | ":WA throws error.") 157 | (is-error (macroexpand-1 158 | '(defclass/std class3 () 159 | ((field :ra)))) 160 | 'simple-error 161 | ":RA throws error.")) 162 | 163 | (run-test-all) 164 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # defclass-std - Standard class writing macro 2 | [![Quicklisp](http://quickdocs.org/badge/defclass-std.svg)](http://quickdocs.org/defclass-std/) 3 | [![Build Status](https://travis-ci.org/EuAndreh/defclass-std.svg?branch=master)](https://travis-ci.org/EuAndreh/defclass-std) 4 | [![Circle CI](https://circleci.com/gh/EuAndreh/defclass-std.svg?style=svg)](https://circleci.com/gh/EuAndreh/defclass-std) 5 | [![Coverage Status](https://coveralls.io/repos/EuAndreh/defclass-std/badge.svg?branch=master)](https://coveralls.io/r/EuAndreh/defclass-std?branch=master) 6 | 7 | Most times, when sketching out a new class, I often commit lots of typos and forget to add an `:initform`. 8 | 9 | Also, the throw away class designed in the beginning may thrive and stay the same. If only there was a way to overcome these problems... There is! 10 | 11 | This simple macro atempts to give a very DRY and succint interface to the common `DEFCLASS` form. The goal is to offer most of the capabilities of a normal `DEFCLASS`, only in a more compact way. 12 | 13 | Everything compiles down to `DEFCLASS`. 14 | 15 | ## Usage 16 | ```lisp 17 | * (ql:quickload :defclass-std) 18 | ; => (:DEFCLASS-STD) 19 | * (import 'defclass-std:defclass/std) 20 | ; => T 21 | ``` 22 | 23 | A simple class defined with `DEFCLASS/STD` looks like this: 24 | ```lisp 25 | (defclass/std example () 26 | ((slot1 slot2 slot3))) 27 | 28 | ; which expands to: 29 | 30 | (DEFCLASS EXAMPLE () 31 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 32 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 33 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL))) 34 | ``` 35 | As you can see, by default, the macro adds three options: 36 | 1. `:accessor` + the name of the slot 37 | 2. `:initarg` + the name of the slot 38 | 3. `:initform nil` 39 | 40 | If you want to change the `:initform` value, you can use the `:std` option: 41 | ```lisp 42 | (defclass std-test () 43 | ((slot :std 1))) 44 | 45 | ; expands to: 46 | 47 | (DEFCLASS STD-TEST () 48 | ((SLOT :ACCESSOR SLOT :INITARG :SLOT :INITFORM 1))) 49 | ``` 50 | 51 | If you want to omit the `:initform` option, you have two ways: 52 | 1. Use `:std :unbound` explicitly 53 | 2. Change the value of `*default-std*`. By default it is set to `T`, so, when the `:std` option is omitted, `:initform` is set to nil. When `*default-std*` is set to nil, `:initform` is omitted when `:std` is omitted. 54 | ```lisp 55 | (defclass/std omit-std () 56 | ((slot :std :unbound))) 57 | 58 | ; which is (semantically) equivalent to: 59 | (eval-when (:compile-toplevel :load-toplevel :execute) 60 | (setf *default-std* nil)) 61 | (defclass/std omit-std () 62 | ((slot))) 63 | 64 | ; which (both) expands to: 65 | 66 | (DEFCLASS OMIT-STD () 67 | ((SLOT :ACCESSOR SLOT :INITARG :SLOT))) 68 | ``` 69 | 70 | `:a`, `:i`, `:r` and `:w` are connected: when all of them are omitted, `:a` and `:i` are inserted by default. 71 | 72 | `:a` stands for `:accessor`, `:i` stands for `:initarg`, `:r` stands for `:reader` and `:w` stands for `:writer`. 73 | 74 | If any of those is present, the default (`:a` and `:i`) is omitted. 75 | ```lisp 76 | (defclass/std airw () 77 | ((slot1 slot2) 78 | (slot3 slot4 :r) 79 | (slot5 :w) 80 | (slot6 :a) 81 | (slot7 :ri))) 82 | 83 | ; which expands to: 84 | 85 | (DEFCLASS AIRW () 86 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 87 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 88 | (SLOT3 :READER SLOT3 :INITFORM NIL) 89 | (SLOT4 :READER SLOT4 :INITFORM NIL) 90 | (SLOT5 :WRITER SLOT5 :INITFORM NIL) 91 | (SLOT6 :ACCESSOR SLOT6 :INITFORM NIL) 92 | (SLOT7 :READER SLOT7 :INITARG :SLOT7 :INITFORM NIL))) 93 | ``` 94 | Note that slot7 has an `:ri` option. That's just `:r` and `:i` together. 95 | 96 | If you want to use `:r` and `:w` together, use `:a` instead, or you'll get an error. The same stands for `:a` + `:r` and `:a` + `:w`. 97 | 98 | You can choose to add the class name as a prefix for the acessor/reader/writer function. Just put `:with` or `:with-prefix` option. 99 | 100 | ```lisp 101 | (defclass/std example () 102 | ((slot1 :with) 103 | (slot2))) 104 | 105 | ; which expands to: 106 | 107 | (DEFCLASS EXAMPLE () 108 | ((SLOT1 :ACCESSOR EXAMPLE-SLOT1 :INITARG :SLOT1 :INITFORM NIL) 109 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL))) 110 | ``` 111 | 112 | To make a slot static (class-allocated), use `:@@` or `:static`. 113 | 114 | To declare the type of a slot or to add documentation to a slot, use `:type` and `:doc`, respectively. 115 | 116 | For real quick, concise, dense and standard class definitions, use `CLASS/STD`: 117 | ```lisp 118 | (class/std example slot1 slot2 slot3) 119 | 120 | ; which expands to: 121 | 122 | (DEFCLASS/STD EXAMPLE () 123 | ((SLOT1 SLOT2 SLOT3))) 124 | 125 | ; which expands to: 126 | 127 | (DEFCLASS EXAMPLE () 128 | ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL) 129 | (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL) 130 | (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL))) 131 | ``` 132 | 133 | You can also add the prefix by default by changing the value of the `*with-prefix*` special variable (defaults to `nil`): 134 | ```lisp 135 | (eval-when (:compile-toplevel :load-toplevel :execute) 136 | (setf *with-prefix* t)) 137 | (defclass/std pre () 138 | ((fix))) 139 | 140 | ; which expands to: 141 | 142 | (DEFCLASS PRE () 143 | ((FIX :ACCESSOR PRE-FIX :INITARG :FIX))) 144 | ``` 145 | 146 | Unknown keywords are left intact: 147 | ```lisp 148 | (defclass/std unknown () 149 | ((slot :unknown :keywords))) 150 | 151 | ; which expands to: 152 | 153 | (DEFCLASS UNKNOWN () 154 | ((SLOT :ACCESSOR SLOT :INITARG :SLOT :INITFORM NIL :KEYWORDS :UNKNOWN))) 155 | 156 | 157 | ; Or, even using custom accessors: 158 | 159 | (defclass/std unknown () 160 | ((slot :unknown :wi :keywords))) 161 | 162 | ; which expands to: 163 | 164 | (DEFCLASS UNKNOWN () 165 | ((SLOT :WRITER SLOT :INITARG :SLOT :INITFORM NIL :KEYWORDS :UNKNOWN))) 166 | ``` 167 | ## Examples 168 | 169 | ```lisp 170 | (defclass/std computer (gadget) 171 | ((screen mouse keyboard :a :type string :with-prefix) 172 | (bluetooth touchpad :wi) 173 | (speaker microphone :r) 174 | (place :@@ :with :doc "Where it is" :r) 175 | (owner :static :std "Me" :w))) 176 | 177 | ; expands to: 178 | 179 | (DEFCLASS COMPUTER (GADGET) 180 | ((SCREEN :ACCESSOR COMPUTER-SCREEN :INITFORM NIL :TYPE STRING) 181 | (MOUSE :ACCESSOR COMPUTER-MOUSE :INITFORM NIL :TYPE STRING) 182 | (KEYBOARD :ACCESSOR COMPUTER-KEYBOARD :INITFORM NIL :TYPE STRING) 183 | (BLUETOOTH :WRITER BLUETOOTH :INITARG :BLUETOOTH :INITFORM NIL) 184 | (TOUCHPAD :WRITER TOUCHPAD :INITARG :TOUCHPAD :INITFORM NIL) 185 | (SPEAKER :READER SPEAKER :INITFORM NIL) 186 | (MICROPHONE :READER MICROPHONE :INITFORM NIL) 187 | (PLACE :READER COMPUTER-PLACE :INITFORM NIL :ALLOCATION :CLASS 188 | :DOCUMENTATION "Where it is") 189 | (OWNER :WRITER OWNER :INITFORM "Me" :ALLOCATION :CLASS))) 190 | ``` 191 | 192 | Real life examples: 193 | 194 | From [cl-inflector](https://github.com/AccelerationNet/cl-inflector/blob/master/langs.lisp][cl-inflector): 195 | ```lisp 196 | (defclass language () 197 | ((name :accessor name :initarg :name :initform nil) 198 | (plurals :accessor plurals :initarg :plurals :initform nil) 199 | (singulars :accessor singulars :initarg :singulars :initform nil) 200 | (uncountables :accessor uncountables :initarg :uncountables :initform nil) 201 | (irregulars :accessor irregulars :initarg :irregulars :initform nil))) 202 | 203 | ; could be written: 204 | 205 | (defclass/std language () 206 | ((name plurals singulars uncountables irregulars))) 207 | 208 | ; or, using CLASS/STD: 209 | 210 | (class/std language name plurals singulars uncountables irregulars) 211 | ``` 212 | From [clack](https://github.com/fukamachi/clack/blob/9804d0b57350032ebdcf8539bae376b5528ac1f6/src/core/handler.lisp): 213 | ```lisp 214 | (defclass () 215 | ((server-name :type keyword 216 | :initarg :server-name 217 | :accessor server-name) 218 | (acceptor :initarg :acceptor 219 | :accessor acceptor))) 220 | 221 | ; could be written (with *default-std* set to nil) 222 | (defclass/std language () 223 | ((server-name :type keyword) 224 | (acceptor))) 225 | ``` 226 | From [RESTAS](https://github.com/archimag/restas/blob/3e37f868141c785d2468fab342d57cca2e2a40dd/src/route.lisp): 227 | ```lisp 228 | (defclass route (routes:route) 229 | ((symbol :initarg :symbol :reader route-symbol) 230 | (module :initarg :module :initform nil :reader route-module) 231 | (required-method :initarg :required-method :initform nil 232 | :reader route-required-method) 233 | (arbitrary-requirement :initarg :arbitrary-requirement :initform nil 234 | :reader route-arbitrary-requirement) 235 | (render-method :initarg :render-method :initform #'identity) 236 | (headers :initarg :headers :initform nil :reader route-headers) 237 | (variables :initarg :variables :initform nil) 238 | (additional-variables :initarg :additional-variables :initform nil))) 239 | 240 | ; could be written 241 | (defclass/std route (routes-route) 242 | ((symbol :ri :with-prefix :std :unbound) 243 | (module required-method arbitrary-requirement 244 | headers variables additional-variables :ri) 245 | (render-method :i :std #'identity) 246 | (header :ir))) 247 | ``` 248 | From [defclass-star example](http://common-lisp.net/project/defclass-star/configuration.lisp.html): 249 | ```lisp 250 | (defclass configuration () 251 | ((package-name :type symbol :initarg :package-name :accessor package-name-of) 252 | (package-nicknames :initform '() :initarg :package-nicknames :accessor package-nicknames-of) 253 | (included-files :initform '() :initarg :included-files :accessor included-files-of) 254 | (gccxml-path :initform "gccxml" :initarg :gccxml-path :accessor gccxml-path-of) 255 | (gccxml-flags :initform "" :initarg :gccxml-flags :accessor gccxml-flags-of) 256 | (hidden-symbols :initform '() :initarg :hidden-symbols :accessor hidden-symbols-of) 257 | (output-filename :initform nil :initarg :output-filename :accessor output-filename-of) 258 | (options :initform (standard-configuration-options) 259 | :initarg :options 260 | :accessor options-of) 261 | (symbol-export-filter :initform 'standard-symbol-export-filter 262 | :type (or (function (symbol)) symbol) 263 | :initarg :symbol-export-filter 264 | :accessor symbol-export-filter-of) 265 | (function-name-transformer :initform 'standard-name-transformer 266 | :type (or (function (string)) symbol) 267 | :initarg :function-name-transformer 268 | :accessor function-name-transformer-of) 269 | (variable-name-transformer :initform 'standard-name-transformer 270 | :type (or (function (string)) symbol) 271 | :initarg :variable-name-transformer 272 | :accessor variable-name-transformer-of) 273 | (type-name-transformer :initform 'standard-name-transformer 274 | :type (or (function (string)) symbol) 275 | :initarg :type-name-transformer 276 | :accessor type-name-transformer-of) 277 | (temp-directory :initform (make-pathname :directory "/tmp") 278 | :initarg :temp-directory 279 | :accessor temp-directory-of) 280 | (working-directory :initform *default-pathname-defaults* 281 | :initarg :working-directory 282 | :accessor working-directory-of))) 283 | 284 | ;;; And the equivalent defclass* version (56 tree leaves): 285 | (defclass* configuration () 286 | ((package-name 287 | :type symbol) 288 | (package-nicknames '()) 289 | (included-files '()) 290 | (gccxml-path "gccxml") 291 | (gccxml-flags "") 292 | (hidden-symbols '()) 293 | (output-filename nil) 294 | (options (standard-configuration-options)) 295 | (symbol-export-filter 'standard-symbol-export-filter 296 | :type (or (function (symbol)) symbol)) 297 | (function-name-transformer 'standard-name-transformer 298 | :type (or (function (string)) symbol)) 299 | (variable-name-transformer 'standard-name-transformer 300 | :type (or (function (string)) symbol)) 301 | (type-name-transformer 'standard-name-transformer 302 | :type (or (function (string)) symbol)) 303 | (temp-directory (make-pathname :directory "/tmp")) 304 | (working-directory *default-pathname-defaults*))) 305 | 306 | ;; And the equivalent defclass/std version (46 tree leaves): 307 | (defclass/std configuration () 308 | ((package-name :type symbol :std :unbound) 309 | (package-nicknames included-files hidden-symbols output-filename) 310 | (gccxml-path :std "gccxml") 311 | (gccxml-flags :std "") 312 | (options :std (standard-configuration-options)) 313 | (symbol-export-filter :std 'standard-symbol-export-filter 314 | :type (or (function (symbol)) symbol)) 315 | (function-name-transformer variable-name-transformer type-name-transformer 316 | :std 'standard-name-transformer 317 | :type (or (function (string)) symbol)) 318 | (temp-directory :std (make-pathname :directory "/tmp")) 319 | (working-directory :std *default-pathname-defaults*))) 320 | ``` 321 | From [cl-hue](https://github.com/jd/cl-hue/blob/master/cl-hue.lisp): 322 | ```lisp 323 | (defclass light () 324 | ((bridge :initarg :bridge :accessor light-bridge) 325 | (number :initarg :number :accessor light-number) 326 | (type :initarg :type :accessor light-type) 327 | (name :initarg :name :accessor light-name) 328 | (modelid :initarg :modelid :accessor light-modelid) 329 | (uniqueid :initarg :uniqueid :accessor light-uniqueid) 330 | (swversion :initarg :swversion :accessor light-swversion) 331 | (pointsymbol :initarg :pointsymbol :accessor light-pointsymbol) 332 | (on :initarg :on :accessor light-on-p) 333 | (brightness :initarg :brightness :accessor light-brightness) 334 | (hue :initarg :hue :accessor light-hue) 335 | (saturation :initarg :saturation :accessor light-saturation) 336 | (xy :initarg :xy :accessor light-xy) 337 | (ct :initarg :ct :accessor light-ct) 338 | (alert :initarg :alert :accessor light-alert) 339 | (effect :initarg :effect :accessor light-effect) 340 | (colormode :initarg :colormode :accessor light-colormode) 341 | (reachable :initarg :reachable :accessor light-reachable-p))) 342 | 343 | ; could be written: 344 | (defclass/std light () 345 | ((bridge number type name modelid uniqueid swversion pointsymbol on brightness 346 | hue saturation xy ct alert effect colormode reachable 347 | :with-prefix :std :unbound))) 348 | 349 | ; or, using class/std: 350 | 351 | (class/std light 352 | bridge number type name modelid uniqueid swversion pointsymbol on brightness 353 | hue saturation xy ct alert effect colormode reachable 354 | :std :unbound :with) 355 | 356 | ; or, with *default-std* set to nil and *with-prefix* set to t: 357 | 358 | (class/std light 359 | bridge number type name modelid uniqueid swversion pointsymbol on brightness 360 | hue saturation xy ct alert effect colormode reachable) 361 | ``` 362 | 363 | There's a shortcut to setup a basic printing behaviour of a class, using `printing-unreadably`: 364 | ```lisp 365 | (printing-unreadably (field2 field3) (class/std myclass field1 field2 field3)) 366 | 367 | ; which expands to: 368 | 369 | (PROGN 370 | (CLASS/STD MYCLASS FIELD1 FIELD2 FIELD3) 371 | (DEFMETHOD PRINT-OBJECT ((MYCLASS MYCLASS) #:STREAM1722) 372 | (PRINT-UNREADABLE-OBJECT (MYCLASS #:STREAM1722 :TYPE T :IDENTITY T) 373 | (FORMAT #:STREAM1722 "FIELD2: ~s, FIELD3: ~s" 374 | (FIELD2 MYCLASS) (FIELD3 MYCLASS))))) 375 | ``` 376 | 377 | ## Dependencies 378 | This project depends only on [Anaphora](http://common-lisp.net/project/anaphora/) and [Alexandria](https://common-lisp.net/project/alexandria/) libraries. The test package uses the [prove](github.com/fukamachi/prove) test library. 379 | 380 | ## Installation 381 | Available on [Quicklisp](http://quicklisp.org): 382 | ``` 383 | (ql:quickload :defclass-std) 384 | ``` 385 | 386 | ## Bugs 387 | If you find any bug or inconsistency in the code, or if you find it too hard to use, please, feel free to open an issue. 388 | 389 | ## Tests 390 | This library is tested under [ABCL](https://common-lisp.net/project/armedbear/), [SBCL](http://www.sbcl.org/), [CCL](http://ccl.clozure.com/), [CLISP](http://www.clisp.org/) and [ECL](https://common-lisp.net/project/ecl/) Common Lisp implementations. 391 | 392 | To run all the defined tests, use: 393 | ```lisp 394 | * (asdf:test-system :defclass-std) 395 | ; prints lots of (colorful) stuff... 396 | ; => T 397 | ``` 398 | Tests are ran with [Travis CI](https://travis-ci.org/EuAndreh/defclass-std) and [Circle CI](https://circleci.com/gh/EuAndreh/defclass-std) using [cl-travis](https://github.com/luismbo/cl-travis), [CIM](https://github.com/KeenS/CIM), [cl-coveralls](https://github.com/fukamachi/cl-coveralls) and [Roswell](https://github.com/snmsts/roswell). Check it out! 399 | 400 | ## Authors 401 | + [André Miranda](https://github.com/EuAndreh) 402 | + [Joram Schrijver](https://github.com/jorams) 403 | 404 | ## License 405 | [LLGPL](https://tldrlegal.com/license/lisp-lesser-general-public-license#fulltext). 406 | --------------------------------------------------------------------------------