ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

records: Factorize error-reporting macro.

Browse source 
* guix/records.scm (record-error): New macro.
  (define-record-type*)[error*]: Remove.
  Use 'record-error' instead.
This commit is contained in:
Ludovic Courtès 2014-07-17 16:42:19 +02:00
parent 23e9a68088
commit b1353e7a6b
1 changed files with 24 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
guix/records.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -34,6 +34,14 @@ (define-module (guix records)
;;; ;;;
;;; Code: ;;; Code:
(define-syntax record-error
(syntax-rules ()
"Report a syntactic error in use of CONSTRUCTOR."
((_ constructor form fmt args ...)
(syntax-violation constructor
(format #f fmt args ...)
form))))
(define-syntax define-record-type* (define-syntax define-record-type*
(lambda (s) (lambda (s)
"Define the given record type such that an additional \"syntactic "Define the given record type such that an additional \"syntactic
@ -107,25 +115,21 @@ (define (field-value f)
#`(lambda () #,value) #`(lambda () #,value)
value)))) value))))
(let-syntax ((error*
(syntax-rules ()
((_ fmt args (... ...))
(syntax-violation 'name
(format #f fmt args
(... ...))
s)))))
(let ((fields (append fields (map car dflt)))) (let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected) (cond ((lset= eq? fields 'expected)
#`(let* #,(field-bindings #`(let* #,(field-bindings
#'((field value) (... ...))) #'((field value) (... ...)))
(ctor #,@(map field-value 'expected)))) (ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected)) ((pair? (lset-difference eq? fields 'expected))
(error* "extraneous field initializers ~a" (record-error 'name s
(lset-difference eq? fields 'expected))) "extraneous field initializers ~a"
(lset-difference eq? fields
'expected)))
(else (else
(error* "missing field initializers ~a" (record-error 'name s
"missing field initializers ~a"
(lset-difference eq? 'expected (lset-difference eq? 'expected
fields))))))))))))) fields))))))))))))
(define (field-default-value s) (define (field-default-value s)
(syntax-case s (default) (syntax-case s (default)