Re: GOOPS functional setter

[Christopher Allan Webber <cwebber@dustycloud.org>]

[-- Attachment #1: Type: text/plain, Size: 1145 bytes --]

tomas@tuxteam.de writes:

> Curiously, Jan (also in this thread) came up with "clone",
> independently.

Yes you're right. :)

Speaking of Jan and I both thinking about clone'ish things, we did a bit
of talking on IRC and I think we have a very nice version of functional
setters where you can "clone" multiple fields at the same time.

Here's what it looks like in practice, adapting from the
(srfi srfi-9 gnu) code:

  (define fsf-address
    (make <address>
      #:street "Franklin Street"
      #:city "Boston"
      #:country "USA"))

  (define rms
    (make <person>
      #:age 30
      #:email "rms@gnu.org"
      #:address fsf-address))

  (define new-rms
    (clone rms
           ((.age) 60)
           ((.address .street) "Temple Place")))

  scheme@(guile-user)> (.age rms)
  $12 = 30
  scheme@(guile-user)> (.age new-rms)
  $13 = 60
  scheme@(guile-user)> (.street (.address rms))
  $14 = "Franklin Street"
  scheme@(guile-user)> (.street (.address new-rms))
  $15 = "Temple Place"

... not bad, eh?

Updated copy of goops-functional-setter.scm attached!  What do other
people think?  Should I try to get this upstream in Guile?


[-- Attachment #2: goops-functional-setter.scm --]
[-- Type: text/plain, Size: 2764 bytes --]

;; By Christopher Allan Webber, LGPLv3+; adapted from shallow-clone in GOOPS
(use-modules (oop goops)
             (ice-9 match))

(define-method (slot-fset (self <object>) slot-name value)
  "Return a new copy of SELF, with all slots preserved except SLOT-NAME
set to VALUE."
  (let* ((class (class-of self))
         (clone (allocate-instance class '())))
    (for-each (lambda (slot)
                (define slot-n
                  (slot-definition-name slot))
                (if (and (not (eq? slot-n slot-name)) (slot-bound? self slot-n))
                    (slot-set! clone slot-n (slot-ref self slot-n))))
              (class-slots class))
    ;; Set the particular slot we're overriding
    (slot-set! clone slot-name value)
    clone))

\f
;; By Christopher Allan Webber, LGPLv3+
;; Inspired by a conversation with Jan Nieuwenhuizen... thanks for the
;; help, Jan!
;; This one does an "immutable" interface cloned-with-adjustments
;; version of things that can change multiple fields at the same time.
;; It uses, and requires, accessors to work on the adjusted fields.

(use-modules (oop goops)
             (ice-9 match))

(define (do-clone obj adjust-fields)
  (define new (shallow-clone obj))
  (for-each
   (match-lambda
     ;; Apply just this one field
     (((accessor) val)
      (set! (accessor new) val))
     ;; Recursively apply fields
     (((accessor recur-fields ...) val)
      (set! (accessor new)
            (do-clone (accessor new)
                      (list (list recur-fields val))))))
   adjust-fields)
  new)

(define-syntax-rule (clone obj ((fields ...) val) ...)
  (do-clone obj
            (list (list (list fields ...) val) ...)))

;; That's all the code.
;; Now here's an example adapted from the (srfi srfi-9 gnu)
;; documentation.

(define-class <address> ()
  (street #:init-keyword #:street
          #:accessor .street)
  (city #:init-keyword #:city
        #:accessor .city)
  (country #:init-keyword #:country
           #:accessor .country))

(define-class <person> ()
  (age #:init-keyword #:age
       #:accessor .age)
  (email #:init-keyword #:email
         #:accessor .email)
  (address #:init-keyword #:address
           #:accessor .address))


(define fsf-address
  (make <address> 
    #:street "Franklin Street"
    #:city "Boston"
    #:country "USA"))

(define rms
  (make <person>
    #:age 30
    #:email "rms@gnu.org"
    #:address fsf-address))

(define new-rms
  (clone rms 
         ((.age) 60)
         ((.address .street) "Temple Place")))

;; scheme@(guile-user)> (.age rms)
;; $12 = 30
;; scheme@(guile-user)> (.age new-rms)
;; $13 = 60
;; scheme@(guile-user)> (.street (.address rms))
;; $14 = "Franklin Street"
;; scheme@(guile-user)> (.street (.address new-rms))
;; $15 = "Temple Place"