ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -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

44
guix/records.scm
View file

@ -1,5 +1,5 @@
;;; 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.
;;;
@ -34,6 +34,14 @@ (define-module (guix records)
;;;
;;; 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*
(lambda (s)
"Define the given record type such that an additional \"syntactic
@ -107,25 +115,21 @@ (define (field-value 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)
#`(let* #,(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)))))))))))))
(let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected)
#`(let* #,(field-bindings
#'((field value) (... ...)))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected))
(record-error 'name s
"extraneous field initializers ~a"
(lset-difference eq? fields
'expected)))
(else
(record-error 'name s
"missing field initializers ~a"
(lset-difference eq? 'expected
fields))))))))))))
(define (field-default-value s)
(syntax-case s (default)