licenses: Let 'license?' expand to #t in trivial cases.

With this change, we have:

  > ,expand (license? gpl3+)
  $2 = #t
  > ,expand (license? something-else)
  $3 = (let ((obj something-else))
    (and ((@@ (srfi srfi-9) struct?) obj)
	 ((@@ (srfi srfi-9) eq?)
	  ((@@ (srfi srfi-9) struct-vtable) obj)
	  (@@ (guix licenses) <license>))))

* guix/licenses.scm (define-license-predicate)
(begin-license-definitions): New macros
<top level>: Wrap definitions in 'begin-license-definitions'.
This commit is contained in:
Ludovic Courtès 2022-10-01 16:49:17 +02:00
parent 3c54b28ea3
commit 79b390a207
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@ -109,13 +109,6 @@ (define-module (guix licenses)
hpnd
fsdg-compatible))
(define-record-type <license>
(license name uri comment)
license?
(name license-name)
(uri license-uri)
(comment license-comment))
;;; Commentary:
;;;
;;; Available licenses.
@ -129,6 +122,53 @@ (define-record-type <license>
;;;
;;; Code:
(define-record-type <license>
(license name uri comment)
actual-license?
(name license-name)
(uri license-uri)
(comment license-comment))
(define-syntax define-license-predicate
(syntax-rules (define define*)
"Define PREDICATE as a license predicate that, when applied to trivial
cases, reduces to #t at macro-expansion time."
((_ predicate (variables ...) (procedures ...)
(define variable _) rest ...)
(define-license-predicate
predicate
(variable variables ...) (procedures ...)
rest ...))
((_ predicate (variables ...) (procedures ...)
(define* (procedure _ ...) _ ...)
rest ...)
(define-license-predicate
predicate
(variables ...) (procedure procedures ...)
rest ...))
((_ predicate (variables ...) (procedures ...))
(define-syntax predicate
(lambda (s)
(syntax-case s (variables ... procedures ...)
((_ variables) #t) ...
((_ (procedures _)) #t) ...
((_ obj) #'(actual-license? obj))
(id
(identifier? #'id)
#'actual-license?)))))))
(define-syntax begin-license-definitions
(syntax-rules ()
((_ predicate definitions ...)
(begin
;; Define PREDICATE such that it expands to #t when passed one of the
;; identifiers in DEFINITIONS.
(define-license-predicate predicate () () definitions ...)
definitions ...))))
(begin-license-definitions license?
(define agpl1
(license "AGPL 1"
"https://gnu.org/licenses/agpl.html"
@ -717,6 +757,6 @@ (define* (fsdg-compatible uri #:optional (comment ""))
https://www.gnu.org/distros/free-system-distribution-guidelines.en.html#non-functional-data."
(license "FSDG-compatible"
uri
comment))
comment)))
;;; licenses.scm ends here