Browse Source
* guix/utils.scm (define-record-type*): Move to...
* guix/records.scm: ... here. New file.
* guix/build-system.scm, guix/packages.scm: Use it.
* guix/gnu-maintenance.scm: Likewise.
(official-gnu-packages)[alist->record]: Remove.
* guix/scripts/substitute-binary.scm: Likewise.
(alist->record, object->fields): Remove.
* tests/utils.scm ("define-record-type*", "define-record-type* with
letrec* behavior", "define-record-type* & inherit",
"define-record-type* & inherit & letrec* behavior",
"define-record-type* & thunked", "define-record-type* & thunked &
default", "define-record-type* & thunked & inherited"): Move to...
* tests/records.scm: ... here. New file.
version-0.8.3
Ludovic Courtès
9 years ago
9 changed files with 368 additions and 307 deletions
@ -0,0 +1,214 @@ |
|||
;;; GNU Guix --- Functional package management for GNU |
|||
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> |
|||
;;; |
|||
;;; This file is part of GNU Guix. |
|||
;;; |
|||
;;; GNU Guix is free software; you can redistribute it and/or modify it |
|||
;;; under the terms of the GNU General Public License as published by |
|||
;;; the Free Software Foundation; either version 3 of the License, or (at |
|||
;;; your option) any later version. |
|||
;;; |
|||
;;; GNU Guix is distributed in the hope that it will be useful, but |
|||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
;;; GNU General Public License for more details. |
|||
;;; |
|||
;;; You should have received a copy of the GNU General Public License |
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
|||
|
|||
(define-module (guix records) |
|||
#:use-module (srfi srfi-1) |
|||
#:use-module (srfi srfi-9) |
|||
#:use-module (srfi srfi-26) |
|||
#:use-module (ice-9 match) |
|||
#:export (define-record-type* |
|||
alist->record |
|||
object->fields)) |
|||
|
|||
;;; Commentary: |
|||
;;; |
|||
;;; Utilities for dealing with Scheme records. |
|||
;;; |
|||
;;; Code: |
|||
|
|||
(define-syntax define-record-type* |
|||
(lambda (s) |
|||
"Define the given record type such that an additional \"syntactic |
|||
constructor\" is defined, which allows instances to be constructed with named |
|||
field initializers, à la SRFI-35, as well as default values." |
|||
(define (make-syntactic-constructor type name ctor fields thunked defaults) |
|||
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and |
|||
expects all of FIELDS to be initialized. DEFAULTS is the list of |
|||
FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of |
|||
thunked fields." |
|||
(with-syntax ((type type) |
|||
(name name) |
|||
(ctor ctor) |
|||
(expected fields) |
|||
(defaults defaults)) |
|||
#`(define-syntax name |
|||
(lambda (s) |
|||
(define (record-inheritance orig-record field+value) |
|||
;; Produce code that returns a record identical to |
|||
;; ORIG-RECORD, except that values for the FIELD+VALUE alist |
|||
;; prevail. |
|||
(define (field-inherited-value f) |
|||
(and=> (find (lambda (x) |
|||
(eq? f (car (syntax->datum x)))) |
|||
field+value) |
|||
car)) |
|||
|
|||
#`(make-struct type 0 |
|||
#,@(map (lambda (field index) |
|||
(or (field-inherited-value field) |
|||
#`(struct-ref #,orig-record |
|||
#,index))) |
|||
'expected |
|||
(iota (length 'expected))))) |
|||
|
|||
(define (thunked-field? f) |
|||
(memq (syntax->datum f) '#,thunked)) |
|||
|
|||
(define (field-bindings field+value) |
|||
;; Return field to value bindings, for use in `letrec*' below. |
|||
(map (lambda (field+value) |
|||
(syntax-case field+value () |
|||
((field value) |
|||
#`(field |
|||
#,(if (thunked-field? #'field) |
|||
#'(lambda () value) |
|||
#'value))))) |
|||
field+value)) |
|||
|
|||
(syntax-case s (inherit #,@fields) |
|||
((_ (inherit orig-record) (field value) (... ...)) |
|||
#`(letrec* #,(field-bindings #'((field value) (... ...))) |
|||
#,(record-inheritance #'orig-record |
|||
#'((field value) (... ...))))) |
|||
((_ (field value) (... ...)) |
|||
(let ((fields (map syntax->datum #'(field (... ...)))) |
|||
(dflt (map (match-lambda |
|||
((f v) |
|||
(list (syntax->datum f) v))) |
|||
#'defaults))) |
|||
|
|||
(define (field-value f) |
|||
(or (and=> (find (lambda (x) |
|||
(eq? f (car (syntax->datum x)))) |
|||
#'((field value) (... ...))) |
|||
car) |
|||
(let ((value |
|||
(car (assoc-ref dflt |
|||
(syntax->datum f))))) |
|||
(if (thunked-field? f) |
|||
#`(lambda () #,value) |
|||
value)))) |
|||
|
|||
(let-syntax ((error* |
|||
(syntax-rules () |
|||
((_ fmt args (... ...)) |
|||
(syntax-violation 'name |
|||
(format #f fmt args |
|||
(... ...)) |
|||
s))))) |
|||
(let ((fields (append fields (map car dflt)))) |
|||
(cond ((lset= eq? fields 'expected) |
|||
#`(letrec* #,(field-bindings |
|||
#'((field value) (... ...))) |
|||
(ctor #,@(map field-value 'expected)))) |
|||
((pair? (lset-difference eq? fields 'expected)) |
|||
(error* "extraneous field initializers ~a" |
|||
(lset-difference eq? fields 'expected))) |
|||
(else |
|||
(error* "missing field initializers ~a" |
|||
(lset-difference eq? 'expected |
|||
fields))))))))))))) |
|||
|
|||
(define (field-default-value s) |
|||
(syntax-case s (default) |
|||
((field (default val) _ ...) |
|||
(list #'field #'val)) |
|||
((field _ options ...) |
|||
(field-default-value #'(field options ...))) |
|||
(_ #f))) |
|||
|
|||
(define (thunked-field? s) |
|||
;; Return the field name if the field defined by S is thunked. |
|||
(syntax-case s (thunked) |
|||
((field (thunked) _ ...) |
|||
#'field) |
|||
((field _ options ...) |
|||
(thunked-field? #'(field options ...))) |
|||
(_ #f))) |
|||
|
|||
(define (thunked-field-accessor-name field) |
|||
;; Return the name (an unhygienic syntax object) of the "real" |
|||
;; getter for field, which is assumed to be a thunked field. |
|||
(syntax-case field () |
|||
((field get options ...) |
|||
(let* ((getter (syntax->datum #'get)) |
|||
(real-getter (symbol-append '% getter '-real))) |
|||
(datum->syntax #'get real-getter))))) |
|||
|
|||
(define (field-spec->srfi-9 field) |
|||
;; Convert a field spec of our style to a SRFI-9 field spec of the |
|||
;; form (field get). |
|||
(syntax-case field () |
|||
((name get options ...) |
|||
#`(name |
|||
#,(if (thunked-field? field) |
|||
(thunked-field-accessor-name field) |
|||
#'get))))) |
|||
|
|||
(define (thunked-field-accessor-definition field) |
|||
;; Return the real accessor for FIELD, which is assumed to be a |
|||
;; thunked field. |
|||
(syntax-case field () |
|||
((name get _ ...) |
|||
(with-syntax ((real-get (thunked-field-accessor-name field))) |
|||
#'(define-inlinable (get x) |
|||
;; The real value of that field is a thunk, so call it. |
|||
((real-get x))))))) |
|||
|
|||
(syntax-case s () |
|||
((_ type syntactic-ctor ctor pred |
|||
(field get options ...) ...) |
|||
(let* ((field-spec #'((field get options ...) ...))) |
|||
(with-syntax (((field-spec* ...) |
|||
(map field-spec->srfi-9 field-spec)) |
|||
((thunked-field-accessor ...) |
|||
(filter-map (lambda (field) |
|||
(and (thunked-field? field) |
|||
(thunked-field-accessor-definition |
|||
field))) |
|||
field-spec))) |
|||
#`(begin |
|||
(define-record-type type |
|||
(ctor field ...) |
|||
pred |
|||
field-spec* ...) |
|||
(begin thunked-field-accessor ...) |
|||
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor |
|||
#'(field ...) |
|||
(filter-map thunked-field? field-spec) |
|||
(filter-map field-default-value |
|||
#'((field options ...) |
|||
...)))))))))) |
|||
|
|||
(define (alist->record alist make keys) |
|||
"Apply MAKE to the values associated with KEYS in ALIST." |
|||
(let ((args (map (cut assoc-ref alist <>) keys))) |
|||
(apply make args))) |
|||
|
|||
(define (object->fields object fields port) |
|||
"Write OBJECT (typically a record) as a series of recutils-style fields to |
|||
PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs." |
|||
(let loop ((fields fields)) |
|||
(match fields |
|||
(() |
|||
object) |
|||
(((field . get) rest ...) |
|||
(format port "~a: ~a~%" field (get object)) |
|||
(loop rest))))) |
|||
|
|||
;;; records.scm ends here |
|||
@ -0,0 +1,137 @@ |
|||
;;; GNU Guix --- Functional package management for GNU |
|||
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> |
|||
;;; |
|||
;;; This file is part of GNU Guix. |
|||
;;; |
|||
;;; GNU Guix is free software; you can redistribute it and/or modify it |
|||
;;; under the terms of the GNU General Public License as published by |
|||
;;; the Free Software Foundation; either version 3 of the License, or (at |
|||
;;; your option) any later version. |
|||
;;; |
|||
;;; GNU Guix is distributed in the hope that it will be useful, but |
|||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
;;; GNU General Public License for more details. |
|||
;;; |
|||
;;; You should have received a copy of the GNU General Public License |
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
|||
|
|||
(define-module (test-records) |
|||
#:use-module (srfi srfi-64) |
|||
#:use-module (ice-9 match) |
|||
#:use-module (guix records)) |
|||
|
|||
(test-begin "records") |
|||
|
|||
(test-assert "define-record-type*" |
|||
(begin |
|||
(define-record-type* <foo> foo make-foo |
|||
foo? |
|||
(bar foo-bar) |
|||
(baz foo-baz (default (+ 40 2)))) |
|||
(and (match (foo (bar 1) (baz 2)) |
|||
(($ <foo> 1 2) #t)) |
|||
(match (foo (baz 2) (bar 1)) |
|||
(($ <foo> 1 2) #t)) |
|||
(match (foo (bar 1)) |
|||
(($ <foo> 1 42) #t))))) |
|||
|
|||
(test-assert "define-record-type* with letrec* behavior" |
|||
;; Make sure field initializers can refer to each other as if they were in |
|||
;; a `letrec*'. |
|||
(begin |
|||
(define-record-type* <bar> bar make-bar |
|||
foo? |
|||
(x bar-x) |
|||
(y bar-y (default (+ 40 2))) |
|||
(z bar-z)) |
|||
(and (match (bar (x 1) (y (+ x 1)) (z (* y 2))) |
|||
(($ <bar> 1 2 4) #t)) |
|||
(match (bar (x 7) (z (* x 3))) |
|||
(($ <bar> 7 42 21))) |
|||
(match (bar (z 21) (x (/ z 3))) |
|||
(($ <bar> 7 42 21)))))) |
|||
|
|||
(test-assert "define-record-type* & inherit" |
|||
(begin |
|||
(define-record-type* <foo> foo make-foo |
|||
foo? |
|||
(bar foo-bar) |
|||
(baz foo-baz (default (+ 40 2)))) |
|||
(let* ((a (foo (bar 1))) |
|||
(b (foo (inherit a) (baz 2))) |
|||
(c (foo (inherit b) (bar -2))) |
|||
(d (foo (inherit c))) |
|||
(e (foo (inherit (foo (bar 42))) (baz 77)))) |
|||
(and (match a (($ <foo> 1 42) #t)) |
|||
(match b (($ <foo> 1 2) #t)) |
|||
(match c (($ <foo> -2 2) #t)) |
|||
(equal? c d) |
|||
(match e (($ <foo> 42 77) #t)))))) |
|||
|
|||
(test-assert "define-record-type* & inherit & letrec* behavior" |
|||
(begin |
|||
(define-record-type* <foo> foo make-foo |
|||
foo? |
|||
(bar foo-bar) |
|||
(baz foo-baz (default (+ 40 2)))) |
|||
(let* ((a (foo (bar 77))) |
|||
(b (foo (inherit a) (bar 1) (baz (+ bar 1)))) |
|||
(c (foo (inherit b) (baz 2) (bar (- baz 1))))) |
|||
(and (match a (($ <foo> 77 42) #t)) |
|||
(match b (($ <foo> 1 2) #t)) |
|||
(equal? b c))))) |
|||
|
|||
(test-assert "define-record-type* & thunked" |
|||
(begin |
|||
(define-record-type* <foo> foo make-foo |
|||
foo? |
|||
(bar foo-bar) |
|||
(baz foo-baz (thunked))) |
|||
|
|||
(let* ((calls 0) |
|||
(x (foo (bar 2) |
|||
(baz (begin (set! calls (1+ calls)) 3))))) |
|||
(and (zero? calls) |
|||
(equal? (foo-bar x) 2) |
|||
(equal? (foo-baz x) 3) (= 1 calls) |
|||
(equal? (foo-baz x) 3) (= 2 calls))))) |
|||
|
|||
(test-assert "define-record-type* & thunked & default" |
|||
(begin |
|||
(define-record-type* <foo> foo make-foo |
|||
foo? |
|||
(bar foo-bar) |
|||
(baz foo-baz (thunked) (default 42))) |
|||
|
|||
(let ((mark (make-parameter #f))) |
|||
(let ((x (foo (bar 2) (baz (mark)))) |
|||
(y (foo (bar 2)))) |
|||
(and (equal? (foo-bar x) 2) |
|||
(parameterize ((mark (cons 'a 'b))) |
|||
(eq? (foo-baz x) (mark))) |
|||
(equal? (foo-bar y) 2) |
|||
(equal? (foo-baz y) 42)))))) |
|||
|
|||
(test-assert "define-record-type* & thunked & inherited" |
|||
(begin |
|||
(define-record-type* <foo> foo make-foo |
|||
foo? |
|||
(bar foo-bar (thunked)) |
|||
(baz foo-baz (thunked) (default 42))) |
|||
|
|||
(let ((mark (make-parameter #f))) |
|||
(let* ((x (foo (bar 2) (baz (mark)))) |
|||
(y (foo (inherit x) (bar (mark))))) |
|||
(and (equal? (foo-bar x) 2) |
|||
(parameterize ((mark (cons 'a 'b))) |
|||
(eq? (foo-baz x) (mark))) |
|||
(parameterize ((mark (cons 'a 'b))) |
|||
(eq? (foo-bar y) (mark))) |
|||
(parameterize ((mark (cons 'a 'b))) |
|||
(eq? (foo-baz y) (mark)))))))) |
|||
|
|||
(test-end) |
|||
|
|||
|
|||
(exit (= (test-runner-fail-count (test-runner-current)) 0)) |
|||
Loading…
Reference in new issue