Robert Smith avatar Robert Smith committed f39f332

* Make the abstract type unconstructable.
* Add support for field mutation.
* Add support for field destructuring.

Comments (0)

Files changed (1)

-(defmacro defdata (adt-name &body constructors)
-  `(progn
-     (defstruct ,adt-name)
-     ,@(loop :for ctor :in constructors
-             :collect (etypecase ctor
-                        (symbol `(defstruct (,ctor
-                                             (:include ,adt-name)
-                                             (:constructor ,ctor))))
-                        (list (let* ((ctor-name (first ctor))
-                                     (field-types (rest ctor))
-                                     (field-names (mapcar
-                                                   (lambda (x)
-                                                     (declare (ignore x))
-                                                     (gensym (symbol-name ctor-name)))
-                                                   field-types)))
-                                `(defstruct (,ctor-name
-                                             (:include ,adt-name)
-                                             (:constructor ,ctor-name (,@field-names)))
-                                   ,@(mapcar #'(lambda (name type)
-                                                 `(,name (error "Unspecified field.")
-                                                         :type ,type))
-                                      field-names
-                                      field-types))))))
-     ',adt-name))
+;;;; defdata.lisp
+;;;; Copyright (c) 2013 Robert Smith
+
+(defvar *field-suffix* "FIELD-")
+
+(flet ((unwrap-singletons (list)
+         (mapcar #'(lambda (x)
+                     (if (and (listp x)
+                              (= 1 (length x)))
+                         (first x)
+                         x))
+                 list))
+       
+       (ensure-car (obj)
+         (if (consp obj)
+             (car obj)
+             obj))
+       
+       (gen-names (n)
+         (loop :for i :below n
+               :collect (make-symbol (format nil "~A~D" *field-suffix* i)))))
+  
+  (defmacro defdata (adt-name &body constructors)
+    `(progn
+       ;; Define the data type.
+       (defstruct (,adt-name (:constructor nil)))
+       
+       ;; Define each of the field constructors.
+       ,@(loop :for ctor :in (unwrap-singletons constructors)
+               :collect
+               (etypecase ctor
+                 ;; Nullary constructor
+                 (symbol `(defstruct (,ctor
+                                      (:include ,adt-name)
+                                      (:constructor ,ctor))))
+                 (list (let* ((ctor-name (first ctor))
+                              (field-types (rest ctor))
+                              (field-names (gen-names (length field-types))))
+                         `(defstruct (,ctor-name
+                                      (:include ,adt-name)
+                                      (:constructor ,ctor-name (,@field-names)))
+                            ,@(mapcar #'(lambda (name type)
+                                          `(,name (error "Unspecified field.")
+                                                  :type ,type))
+                               field-names
+                               field-types))))))
+       
+       ',adt-name)))
+
+(labels ((field (name n)
+           (intern (format nil "~A-~A~D" name *field-suffix* n)
+                   (symbol-package name)))
+         
+         (wild? (s)
+           (string= "_" (symbol-name s))))
+
+  ;; Setter
+  (defmacro set-data (obj (name &rest new-values))
+    (let ((once (gensym "ONCE")))
+      `(let ((,once ,obj))
+         (psetf
+          ,@(loop :for i :from 0
+                  :for x :in new-values
+                  :when (not (wild? x))
+                    :append (list `(,(field name i) ,once)
+                                  x))))))
+  
+  ;; Destructuring
+  (defmacro with-data ((name &rest vars) obj &body body)
+    (let* ((once (gensym "ONCE-"))
+           (bindings (loop :for i :from 0
+                           :for v :in vars
+                           :when (not (wild? v))
+                             :collect `(,v (,(field name i)
+                                            ,once)))))
+      `(let ((,once ,obj))
+         (let (,@bindings)
+           ,@body)))))
+
+;; TODO
+;; (defmacro match (obj &body clauses))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.