Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Add little immutable struct thing
  • Loading branch information
sjl committed Jan 17, 2017
1 parent bb8bbd5 commit 69bb1f2
Show file tree
Hide file tree
Showing 5 changed files with 233 additions and 99 deletions.
11 changes: 11 additions & 0 deletions package.lisp
Expand Up @@ -258,6 +258,17 @@
(:export
))

(defpackage :sand.istruct
(:use
:cl
:cl-arrows
:losh
:iterate
:sand.quickutils
:sand.utils)
(:export
))


(defpackage :sand.sketch
(:use
Expand Down
1 change: 1 addition & 0 deletions sand.asd
Expand Up @@ -75,6 +75,7 @@
(:file "mandelbrot")
(:file "story")
(:file "qud")
(:file "istruct")
(:module "turing-omnibus"
:serial t
:components ((:file "wallpaper")
Expand Down
115 changes: 115 additions & 0 deletions src/istruct.lisp
@@ -0,0 +1,115 @@
(in-package :sand.istruct)

;;;; Equality -----------------------------------------------------------------
(defgeneric equal? (a b))

(defmethod equal? ((a t) (b t))
nil)

(defmethod equal? ((a number) (b number))
(= a b))

(defmethod equal? ((a string) (b string))
(equal a b))

(defmethod equal? ((a symbol) (b symbol))
(eq a b))


;;;; Retrieval/Modification ---------------------------------------------------
(defun iget (instance slot)
(slot-value instance slot))

(defun iget-in (instance slot-path)
(iterate
(for result :first instance :then (slot-value result slot))
(for slot :in slot-path)
(finally (return result))))


(defgeneric iset (instance slot new-value))

(defun iset-in (instance slot-path new-value)
(destructuring-bind (slot . remaining) slot-path
(if (null remaining)
(iset instance slot new-value)
(iset instance slot (iset-in (iget instance slot)
remaining new-value)))))


(defun iupdate (instance slot function &rest args)
(iset instance slot (apply function (iget instance slot) args)))

(defun iupdate-in (instance slot-path function &rest args)
(destructuring-bind (slot . remaining) slot-path
(if (null remaining)
(apply #'iupdate instance slot function args)
(iset instance slot
(apply #'iupdate-in (iget instance slot)
remaining function args)))))


;;;; Definition ---------------------------------------------------------------
(defun required (name)
(error "Slot ~S is required" name))


(defun build-slot (slot-spec)
(destructuring-bind (slot-name &key default type) slot-spec
`(,slot-name
,(if default
default
`(required ',slot-name))
:read-only t
,@(when type `(:type ,type)))))

(defun build-immutable-struct-form (name slots)
`(defstruct ,name
,@(mapcar #'build-slot slots)))

(defun build-iset (name slots)
`(defmethod iset ((instance ,name) slot new-value)
(,(symb 'make- name)
,@(iterate (for (slot . nil) :in slots)
(collect (ensure-keyword slot))
(collect `(if (eq slot ',slot)
new-value
(slot-value instance ',slot)))))))

(defun build-equal? (name slots)
`(defmethod equal? ((a ,name) (b ,name))
(and ,@(iterate (for (slot . nil) :in slots)
(collect `(equal?
(slot-value a ',slot)
(slot-value b ',slot)))))))

(defun build-constructor (name slots)
(let ((slot-names (mapcar #'first slots)))
`(defun ,name ,slot-names
(,(symb 'make- name)
,@(iterate (for slot :in slot-names)
(collect (ensure-keyword slot))
(collect slot))))))


(defmacro define-istruct (name-and-options &rest slots)
"Define an immutable structure."
(destructuring-bind (name) (ensure-list name-and-options)
(let ((slots (mapcar #'ensure-list slots)))
`(progn
,(build-immutable-struct-form name slots)
,(build-iset name slots)
,(build-equal? name slots)
,(build-constructor name slots)
',name))))


;;;; Scratch ------------------------------------------------------------------
(define-istruct sword
material)

(define-istruct monster
(hp :default 10)
species
(weapon :default nil))

3 changes: 2 additions & 1 deletion vendor/make-quickutils.lisp
Expand Up @@ -10,14 +10,14 @@
:define-constant
:ensure-boolean
:ensure-gethash
:ensure-keyword
:ensure-list
:extremum
:flip
:hash-table-alist
:hash-table-keys
:hash-table-plist
:hash-table-values
:write-string-into-file
:iota
:n-grams
:once-only
Expand All @@ -31,6 +31,7 @@
:symb
:tree-collect
:with-gensyms
:write-string-into-file

)
:package "SAND.QUICKUTILS")

0 comments on commit 69bb1f2

Please sign in to comment.