From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludo@gnu.org (Ludovic =?iso-8859-1?Q?Court=E8s?=) Newsgroups: gmane.lisp.guile.devel Subject: Functional record =?utf-8?B?4oCcc2V0dGVyc+KAnQ==?= Date: Mon, 09 Apr 2012 02:17:35 +0200 Message-ID: <871unxhi74.fsf@gnu.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1333930680 2742 80.91.229.3 (9 Apr 2012 00:18:00 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Mon, 9 Apr 2012 00:18:00 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon Apr 09 02:18:00 2012 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1SH2Ix-0004LF-CM for guile-devel@m.gmane.org; Mon, 09 Apr 2012 02:17:59 +0200 Original-Received: from localhost ([::1]:42784 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1SH2Iw-0005E8-M5 for guile-devel@m.gmane.org; Sun, 08 Apr 2012 20:17:58 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:39754) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1SH2Is-0005E2-29 for guile-devel@gnu.org; Sun, 08 Apr 2012 20:17:56 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1SH2Ip-0008VG-3k for guile-devel@gnu.org; Sun, 08 Apr 2012 20:17:53 -0400 Original-Received: from plane.gmane.org ([80.91.229.3]:56840) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1SH2Io-0008V6-Ka for guile-devel@gnu.org; Sun, 08 Apr 2012 20:17:51 -0400 Original-Received: from list by plane.gmane.org with local (Exim 4.69) (envelope-from ) id 1SH2Il-0004FC-M3 for guile-devel@gnu.org; Mon, 09 Apr 2012 02:17:47 +0200 Original-Received: from reverse-83.fdn.fr ([80.67.176.83]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Mon, 09 Apr 2012 02:17:47 +0200 Original-Received: from ludo by reverse-83.fdn.fr with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Mon, 09 Apr 2012 02:17:47 +0200 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 545 Original-X-Complaints-To: usenet@dough.gmane.org X-Gmane-NNTP-Posting-Host: reverse-83.fdn.fr X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 21 Germinal an 220 de la =?iso-8859-1?Q?R=E9volution?= X-PGP-Key-ID: 0xEA52ECF4 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 83C4 F8E5 10A3 3B4C 5BEA D15D 77DD 95E2 EA52 ECF4 X-OS: x86_64-unknown-linux-gnu User-Agent: Gnus/5.110018 (No Gnus v0.18) Emacs/24.0.93 (gnu/linux) Cancel-Lock: sha1:ZAVPFDnXOgkOXIy8qNku/Q1oHeA= X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 80.91.229.3 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:14229 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Hi! The attached patches do two things: • The first one adds ‘define-immutable-record-type’ in (srfi srfi-9 gnu), which works like this: (define-immutable-record-type bar (make-bar x y z) bar? (x bar-x set-bar-x) (y bar-y set-bar-y)) (equal? (set-bar-y (make-bar 1 0) 2) (make-bar 1 2)) => #t • The second one adds the ‘set-field’ macro, which allows fields within nested records to be set: (define-immutable-record-type address (make-address street city) address? (street address-street) (city address-city)) (define-immutable-record-type person (make-person age address) person? (age person-age) (address person-address)) (let ((p (make-person 30 (make-address "Foo" "Paris")))) (set-field (person-address address-city) p "Düsseldorf")) => #> (This was inspired by “Asymmetric Lenses in Scala”, by Tony Morris.) The implementation uses a simple trick where macros such as ‘person-address’ conditionally accept a second argument to behave as a functional setter; ‘set-field’ just sets a syntax parameter so that this condition holds. Currently there’s no type-checking: if the given fields are not struct accessors, or are unbound, ‘set-field’ expansion takes place anyway. Suggestions to improve this welcome! I’d like to apply these patches and associated documentation in stable-2.0. Thoughts? Thanks, Ludo’. --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-SRFI-9-Add-define-immutable-record-type-as-an-extens.patch Content-Description: first patch >From e38914e1b70cfaa16d1f144268bb52d2fd3c83d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 8 Apr 2012 17:21:56 +0200 Subject: [PATCH 1/2] SRFI-9: Add `define-immutable-record-type' as an extension. * module/srfi/srfi-9.scm (define-record-type): Rename to... (%define-record-type): ... this. Add `immutable?' parameter. [accessors]: Wrap things in `(begin ...)' instead of using `unsyntax-splicing'. [copy-modifier, functional-accessors, record-layout]: New procedures. (define-record-type): Define in terms of `%define-record-type'. * module/srfi/srfi-9/gnu.scm (define-immutable-record-type): New macro. * test-suite/tests/srfi-9.test ("define-immutable-record-type"): New test prefix. --- module/srfi/srfi-9.scm | 97 +++++++++++++++++++++++++++++++++--------- module/srfi/srfi-9/gnu.scm | 14 +++++- test-suite/tests/srfi-9.test | 71 ++++++++++++++++++++++++++++++- 3 files changed, 157 insertions(+), 25 deletions(-) diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index cb8dd0a..07b4afa 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -1,6 +1,6 @@ ;;; srfi-9.scm --- define-record-type -;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -109,7 +109,7 @@ (loop (cdr fields) (+ 1 off))))) (display ">" p)) -(define-syntax define-record-type +(define-syntax %define-record-type (lambda (x) (define (field-identifiers field-specs) (syntax-case field-specs () @@ -156,38 +156,86 @@ 1+ 0))))))) + (define (copy-modifier type-name field-count orig-record field-index + value) + ;; Produce code that returns a record identical to ORIG-RECORD, + ;; except that its field at FIELD-INDEX is set to VALUE. + #`(make-struct #,type-name 0 + #,@(unfold (lambda (field-num) + (>= field-num field-count)) + (lambda (field-num) + (if (= field-num field-index) + value + #`(struct-ref #,orig-record + #,field-num))) + 1+ + 0))) + (define (accessors type-name field-specs indices) (syntax-case field-specs () (() - #'()) + #'(begin)) ((field-spec) (syntax-case #'field-spec () ((name accessor) (with-syntax ((index (assoc-ref indices (syntax->datum #'name)))) - #`((define-inlinable (accessor s) - (if (eq? (struct-vtable s) #,type-name) - (struct-ref s index) - (throw 'wrong-type-arg 'accessor - "Wrong type argument: ~S" (list s) - (list s))))))) + #`(define-inlinable (accessor s) + (if (eq? (struct-vtable s) #,type-name) + (struct-ref s index) + (throw 'wrong-type-arg 'accessor + "Wrong type argument: ~S" (list s) + (list s)))))) ((name accessor modifier) (with-syntax ((index (assoc-ref indices (syntax->datum #'name)))) - #`(#,@(accessors type-name #'((name accessor)) indices) - (define-inlinable (modifier s val) - (if (eq? (struct-vtable s) #,type-name) - (struct-set! s index val) - (throw 'wrong-type-arg 'modifier - "Wrong type argument: ~S" (list s) - (list s))))))))) + #`(begin + #,(accessors type-name #'((name accessor)) indices) + (define-inlinable (modifier s val) + (if (eq? (struct-vtable s) #,type-name) + (struct-set! s index val) + (throw 'wrong-type-arg 'modifier + "Wrong type argument: ~S" (list s) + (list s))))))))) + ((field-spec rest ...) + #`(begin + #,(accessors type-name #'(field-spec) indices) + (begin #,(accessors type-name #'(rest ...) indices)))))) + + (define (functional-accessors type-name field-specs field-count indices) + (syntax-case field-specs () + (() + #'(begin)) + ((field-spec) + (syntax-case #'field-spec () + ((name accessor) + (accessors type-name #'(field-spec) indices)) + ((name accessor modifier) + (let ((index (assoc-ref indices (syntax->datum #'name)))) + #`(begin + #,(functional-accessors type-name #'((name accessor)) + field-count indices) + (define-inlinable (modifier s v) + #,(copy-modifier type-name field-count + #'s index #'v))))))) ((field-spec rest ...) - #`(#,@(accessors type-name #'(field-spec) indices) - #,@(accessors type-name #'(rest ...) indices))))) + #`(begin + #,(functional-accessors type-name #'(field-spec) + field-count indices) + (begin + #,(functional-accessors type-name #'(rest ...) + field-count indices)))))) + + (define (record-layout immutable? count) + (let ((desc (if immutable? "pr" "pw"))) + (string-concatenate (make-list count desc)))) (syntax-case x () - ((_ type-name constructor-spec predicate-name field-spec ...) + ((_ immutable? type-name constructor-spec predicate-name + field-spec ...) + (boolean? (syntax->datum #'immutable?)) (let* ((fields (field-identifiers #'(field-spec ...))) (field-count (length fields)) - (layout (string-concatenate (make-list field-count "pw"))) + (immutable? (syntax->datum #'immutable?)) + (layout (record-layout immutable? field-count)) (indices (field-indices (map syntax->datum fields)))) #`(begin (define type-name @@ -205,6 +253,13 @@ #,(constructor #'type-name #'constructor-spec indices) - #,@(accessors #'type-name #'(field-spec ...) indices))))))) + #,(if immutable? + (functional-accessors #'type-name #'(field-spec ...) + (length #'(field-spec ...)) + indices) + (accessors #'type-name #'(field-spec ...) indices)))))))) + +(define-syntax-rule (define-record-type name ctor pred fields ...) + (%define-record-type #f name ctor pred fields ...)) ;;; srfi-9.scm ends here diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm index 30c101b..e8f424c 100644 --- a/module/srfi/srfi-9/gnu.scm +++ b/module/srfi/srfi-9/gnu.scm @@ -1,6 +1,6 @@ ;;; Extensions to SRFI-9 -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2012 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -23,8 +23,18 @@ ;;; Code: (define-module (srfi srfi-9 gnu) - #:export (set-record-type-printer!)) + #:use-module (srfi srfi-9) + #:export (set-record-type-printer! + define-immutable-record-type)) (define (set-record-type-printer! type thunk) "Set a custom printer THUNK for TYPE." (struct-set! type vtable-index-printer thunk)) + +;; Import (srfi srfi-9)'s private module, so we can use the private +;; `%define-record-type' macro. +(eval-when (compile eval load) + (module-use! (current-module) (resolve-module '(srfi srfi-9)))) + +(define-syntax-rule (define-immutable-record-type name ctor pred fields ...) + (%define-record-type #t name ctor pred fields ...)) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index f26a7a2..18082e2 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -1,7 +1,7 @@ ;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-05-10 ;;;; -;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -20,7 +20,9 @@ (define-module (test-suite test-numbers) #:use-module (test-suite lib) #:use-module ((system base compile) #:select (compile)) - #:use-module (srfi srfi-9)) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu)) (define-record-type :qux (make-qux) qux?) @@ -110,3 +112,68 @@ (let ((frotz (make-frotz 1 2))) (and (= (frotz-a frotz) 1) (= (frotz-b frotz) 2))))) + + +(with-test-prefix "define-immutable-record-type" + + (pass-if "get" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x) + (y bar-y) + (z bar-z)) + + (let ((b (make-bar 1 2 3))) + (and (= (bar-x b) 1) + (= (bar-y b) 2) + (= (bar-z b) 3))))) + + (pass-if "get non-inlined" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x) + (y bar-y) + (z bar-z)) + + (let ((b (make-bar 1 2 3))) + (equal? (map (cute apply <> (list b)) + (list bar-x bar-y bar-z)) + '(1 2 3))))) + + (pass-if "set" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x set-bar-x) + (y bar-y set-bar-y) + (z bar-z set-bar-z)) + + (let* ((b0 (make-bar 1 2 3)) + (b1 (set-bar-x b0 11)) + (b2 (set-bar-y b1 22)) + (b3 (set-bar-z b2 33))) + (and (= (bar-x b0) 1) + (= (bar-x b1) 11) (= (bar-x b2) 11) (= (bar-x b3) 11) + (= (bar-y b0) 2) (= (bar-y b1) 2) + (= (bar-y b2) 22) (= (bar-y b3) 22) + (= (bar-z b0) 3) (= (bar-z b1) 3) (= (bar-z b2) 3) + (= (bar-z b3) 33))))) + + (pass-if "set non-inlined" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x set-bar-x) + (y bar-y set-bar-y) + (z bar-z set-bar-z)) + + (let ((set (compose (cut set-bar-x <> 1) + (cut set-bar-y <> 2) + (cut set-bar-z <> 3)))) + (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3)))))) -- 1.7.6 --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0002-SRFI-9-Add-set-field-as-an-extension.patch Content-Description: second patch >From e86dcb7662a2d75f1d9d683fc31fc5f39734f561 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 9 Apr 2012 01:41:03 +0200 Subject: [PATCH 2/2] SRFI-9: Add `set-field' as an extension. * module/srfi/srfi-9.scm (make-procedure-name): New procedure, formerly in `define-inlinable'. (%reveal-setter): New syntax parameter. (%define-record-type)[functional-accessors]: Mimic `define-inlinable', but add support for (ACCESSOR obj val), when `%reveal-setter' allows it. * test-suite/tests/srfi-9.test ("set-field"): New test prefix. --- module/srfi/srfi-9.scm | 48 ++++++++++++++++++++++++++++++++++++----- module/srfi/srfi-9/gnu.scm | 18 ++++++++++++++- test-suite/tests/srfi-9.test | 42 ++++++++++++++++++++++++++++++++++++ 3 files changed, 101 insertions(+), 7 deletions(-) diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index 07b4afa..3b12105 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -69,13 +69,13 @@ ;; using it would require users to recompile code that uses SRFI-9. See ;; . +(define (make-procedure-name name) + (datum->syntax name + (symbol-append '% (syntax->datum name) + '-procedure))) + (define-syntax define-inlinable (lambda (x) - (define (make-procedure-name name) - (datum->syntax name - (symbol-append '% (syntax->datum name) - '-procedure))) - (syntax-case x () ((_ (name formals ...) body ...) (identifier? #'name) @@ -109,6 +109,12 @@ (loop (cdr fields) (+ 1 off))))) (display ">" p)) +;; Internal parameter used to tell immutable record accessor macros to +;; behave as functional setters when called as (ACCESSOR obj val). +(define-syntax-parameter %reveal-setter + (lambda (s) + (error "form only allowed within `set-field'" (syntax->datum s)))) + (define-syntax %define-record-type (lambda (x) (define (field-identifiers field-specs) @@ -207,7 +213,37 @@ ((field-spec) (syntax-case #'field-spec () ((name accessor) - (accessors type-name #'(field-spec) indices)) + (let ((index (assoc-ref indices (syntax->datum #'name)))) + (with-syntax ((proc-name (make-procedure-name #'name)) + (index (datum->syntax #'name index))) + ;; Mimic `(define-inlinable (accessor s) ...)', but also + ;; allow the (ACCESSOR obj val) form. + #`(begin + (define (proc-name s) + (if (eq? (struct-vtable s) #,type-name) + (struct-ref s index) + (throw 'wrong-type-arg 'accessor + "Wrong type argument: ~S" (list s) + (list s)))) + (define-syntax accessor + (lambda (s) + (syntax-case s () + ((_ s) + #'(if (eq? (struct-vtable s) #,type-name) + (struct-ref s index) + (throw 'wrong-type-arg 'accessor + "Wrong type argument: ~S" (list s) + (list s)))) + ((_ s v) + ;; Behave like a functional setter if + ;; %REVEAL-SETTER permits it. + #'(%reveal-setter + #,(copy-modifier type-name field-count + #'s (syntax->datum #'index) + #'v))) + (_ + (identifier? s) + #'proc-name)))))))) ((name accessor modifier) (let ((index (assoc-ref indices (syntax->datum #'name)))) #`(begin diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm index e8f424c..30845e6 100644 --- a/module/srfi/srfi-9/gnu.scm +++ b/module/srfi/srfi-9/gnu.scm @@ -25,7 +25,8 @@ (define-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9) #:export (set-record-type-printer! - define-immutable-record-type)) + define-immutable-record-type + set-field)) (define (set-record-type-printer! type thunk) "Set a custom printer THUNK for TYPE." @@ -38,3 +39,18 @@ (define-syntax-rule (define-immutable-record-type name ctor pred fields ...) (%define-record-type #t name ctor pred fields ...)) + +(define-syntax set-field + (lambda (s) + "Return a new object copied from OBJ, but with the given FIELDS set +to VAL." + (syntax-case s () + ((_ (f1 fields ...) obj val) + (identifier? #'f1) + #'(let ((r (set-field (fields ...) (f1 obj) val))) + (syntax-parameterize ((%reveal-setter + (syntax-rules () + ((_ x) x)))) + (f1 obj r)))) + ((_ () obj val) + #'val)))) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index 18082e2..74bbcf2 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -177,3 +177,45 @@ (cut set-bar-y <> 2) (cut set-bar-z <> 3)))) (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3)))))) + + +(with-test-prefix "set-field" + (pass-if "one field" + (let () + (define-immutable-record-type bar + (make-bar x y) + bar? + (x bar-x set-bar-x) + (y bar-y set-bar-y)) + + (equal? (set-field (bar-x) (make-bar 77 2) 1) + (make-bar 1 2)))) + + (pass-if "three fields" + (let () + (define-immutable-record-type foo + (make-foo x y z) + foo? + (x foo-x) + (y foo-y) + (z foo-z)) + + (define-immutable-record-type bar + (make-bar xx yy) + bar? + (xx bar-x) + (yy bar-y)) + + (define-immutable-record-type baz + (make-baz a b) + baz? + (a baz-a) + (b baz-b)) + + (let ((s (make-foo 0 (make-bar (make-baz 1 2) 3) 4))) + (equal? (set-field (foo-y bar-x baz-b) s 222) + (make-foo 0 (make-bar (make-baz 1 222) 3) 4))))) + + (pass-if-exception "field is not an identifier" + exception:syntax-pattern-unmatched + (compile '(set-field (1 2 3) s v) #:env (current-module)))) -- 1.7.6 --=-=-=--