diff --git a/maintainers/scripts/gnu/gnupdate b/maintainers/scripts/gnu/gnupdate new file mode 100755 index 000000000000..c0dcd0785532 --- /dev/null +++ b/maintainers/scripts/gnu/gnupdate @@ -0,0 +1,4 @@ +#!/bin/sh + +exec "${GUILE:-guile}" "$GUILE_FLAGS" -L . -l gnupdate.scm \ + -e '(apply main (cdr (command-line)))' -- "$@" diff --git a/maintainers/scripts/gnu/gnupdate.scm b/maintainers/scripts/gnu/gnupdate.scm new file mode 100644 index 000000000000..e43e5baf32c3 --- /dev/null +++ b/maintainers/scripts/gnu/gnupdate.scm @@ -0,0 +1,720 @@ +;;; GNUpdate -- Update GNU packages in Nixpkgs. -*- coding: utf-8; -*- +;;; Copyright (C) 2010 Ludovic Courtès +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see . + +(cond-expand (guile-2 #t) + (else (error "GNU Guile 2.0 is required"))) + +(use-modules (sxml simple) + (ice-9 popen) + (ice-9 match) + (ice-9 rdelim) + (ice-9 regex) + (ice-9 vlist) + (sxml-match) + (srfi srfi-1) + (srfi srfi-9) + (srfi srfi-11) + (srfi srfi-37) + (system foreign) + (rnrs bytevector)) + + +;;; +;;; SNix. +;;; + +(define-record-type + (make-location file line column) + location? + (file location-file) + (line location-line) + (column location-column)) + +(define (->loc line column path) + (and line column path + (make-location path (string->number line) (string->number column)))) + +;; Nix object types visible in the XML output of `nix-instantiate' and +;; mapping to S-expressions (we map to sexps, not records, so that we +;; can do pattern matching): +;; +;; at (at varpat attrspat) +;; attr (attribute loc name value) +;; attrs (attribute-set attributes) +;; attrspat (attribute-set-pattern patterns) +;; bool #f|#t +;; derivation (derivation drv-path out-path attributes) +;; ellipsis '... +;; expr (expr loc body ...) +;; function (function loc at|attrspat|varpat) +;; int int +;; list list +;; null 'null +;; path string +;; string string +;; unevaluated 'unevaluated +;; varpat (varpat name) +;; +;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise; +;; however, handling `repeated' nodes makes it impossible to do anything +;; lazily because the whole SXML tree has to be traversed to maintain the +;; list of known derivations. + +(define (sxml->snix tree) + ;; Return the SNix represention of TREE, an SXML tree as returned by + ;; parsing the XML output of `nix-instantiate' on Nixpkgs. + + ;; FIXME: We should use SSAX to avoid the SXML step otherwise we end up + ;; eating memory up to the point where fork(2) returns ENOMEM! + + (define whitespace + ;; The whitespace marker. + (cons 'white 'space)) + + (let loop ((node tree) + (derivations vlist-null)) + (define (process-body body) + (let ((result+derivations + (fold (lambda (node result) + (let-values (((out derivations) + (loop node (cdr result)))) + (if (eq? out whitespace) + result + (cons (cons out (car result)) + derivations)))) + (cons '() derivations) + body))) + (values (reverse (car result+derivations)) + (cdr result+derivations)))) + + (sxml-match node + (,x + (guard (and (string? x) (string=? (string-trim-both x) ""))) + (values whitespace derivations)) + ((*TOP* (*PI* ,_ ...) (expr ,body ...)) + ;; The entry/exit point. Of the two values returned, the second one + ;; is likely to be discarded by the caller (thanks to multiple-value + ;; truncation). + (let-values (((body derivations) (process-body body))) + (values (cons* 'snix #f body) + derivations))) + ((at ,body ...) + (let-values (((body derivations) (process-body body))) + (values (list 'at body) derivations))) + ((attr (@ (name ,name) + (line (,line #f)) (column (,column #f)) (path (,path #f))) + ,body ...) + (let-values (((body derivations) (process-body body))) + (values (cons* 'attribute + (->loc line column path) + name + (if (or (null? body) + (and (pair? body) (null? (cdr body)))) + body + (error 'sxml->snix "invalid attribute body" + body))) + derivations))) + ((attrs ,body ...) + (let-values (((body derivations) (process-body body))) + (values (list 'attribute-set body) + derivations))) + ((attrspat ,body ...) + (let-values (((body derivations) (process-body body))) + (values (cons 'attribute-set-pattern body) + derivations))) + ((bool (@ (value ,value))) + (values (string-ci=? value "true") derivations)) + ((derivation (@ (drvPath ,drv-path) (outPath ,out-path)) ,body ...) + (let-values (((body derivations) (process-body body))) + (let ((repeated? (equal? body '(repeated)))) + (values (list 'derivation drv-path out-path + (if repeated? + (let ((body (vhash-assoc drv-path derivations))) + (if (pair? body) + (cdr body) + (error "no previous occurrence of derivation" + drv-path))) + body)) + (if repeated? + derivations + (vhash-cons drv-path body derivations)))))) + ((ellipsis) + (values '... derivations)) + ((function (@ (line (,line #f)) (column (,column #f)) (path (,path #f))) + ,body ...) + (let-values (((body derivations) (process-body body))) + (values (cons* 'function + (->loc line column path) + (if (and (pair? body) (null? (cdr body))) + body + (error 'sxml->snix "invalid function body" + body))) + derivations))) + ((int (@ (value ,value))) + (values (string->number value) derivations)) + (,x + ;; We can't use `(list ,body ...)', which has a different meaning, + ;; hence the guard hack. + (guard (and (pair? x) (eq? (car x) 'list))) + (process-body (cdr x))) + ((null) + (values 'null derivations)) + ((path (@ (value ,value))) + (values value derivations)) + ((repeated) + ;; This is then handled in `derivation' above. + (values 'repeated derivations)) + ((string (@ (value ,value))) + (values value derivations)) + ((unevaluated) + (values 'unevaluated derivations)) + ((varpat (@ (name ,name))) + (values (list 'varpat name) derivations)) + (,x + (error 'sxml->snix "unmatched sxml form" x))))) + +(define (call-with-package snix proc) + (match snix + (('attribute _ (and attribute-name (? string?)) + ('derivation _ _ body)) + ;; Ugly pattern matching. + (let ((meta + (any (lambda (attr) + (match attr + (('attribute _ "meta" ('attribute-set metas)) metas) + (_ #f))) + body)) + (package-name + (any (lambda (attr) + (match attr + (('attribute _ "name" (and name (? string?))) + name) + (_ #f))) + body)) + (location + (any (lambda (attr) + (match attr + (('attribute loc "name" (? string?)) + loc) + (_ #f))) + body)) + (src + (any (lambda (attr) + (match attr + (('attribute _ "src" src) + src) + (_ #f))) + body))) + (proc attribute-name package-name location meta src))))) + +(define (call-with-src snix proc) + ;; Assume SNIX contains the SNix expression for the value of an `src' + ;; attribute, as returned by `call-with-package', and call PROC with the + ;; relevant SRC information, or #f if SNIX doesn't match. + (match snix + (('derivation _ _ body) + (let ((name + (any (lambda (attr) + (match attr + (('attribute _ "name" (and name (? string?))) + name) + (_ #f))) + body)) + (output-hash + (any (lambda (attr) + (match attr + (('attribute _ "outputHash" (and hash (? string?))) + hash) + (_ #f))) + body)) + (urls + (any (lambda (attr) + (match attr + (('attribute _ "urls" (and urls (? pair?))) + urls) + (_ #f))) + body))) + (proc name output-hash urls))) + (_ (proc #f #f #f)))) + +(define (src->values snix) + (call-with-src snix values)) + +(define (open-nixpkgs nixpkgs) + (let ((script (string-append nixpkgs + "/maintainers/scripts/eval-release.nix"))) + (open-pipe* OPEN_READ "nix-instantiate" + "--strict" "--eval-only" "--xml" + script))) + +(define (nix-prefetch-url url) + ;; Download URL in the Nix store and return the base32-encoded SHA256 hash + ;; of the file at URL + (let* ((pipe (open-pipe* OPEN_READ "nix-prefetch-url" url)) + (hash (read-line pipe))) + (close-pipe pipe) + (if (eof-object? hash) + (values #f #f) + (let* ((pipe (open-pipe* OPEN_READ "nix-store" "--print-fixed-path" + "sha256" hash (basename url))) + (path (read-line pipe))) + (if (eof-object? path) + (values #f #f) + (values (string-trim-both hash) (string-trim-both path))))))) + +(define (update-nix-expression file + old-version old-hash + new-version new-hash) + ;; Modify FILE in-place. Ugly: we call out to sed(1). + (let ((cmd (format #f "sed -i \"~a\" -e 's/~A/~a/g ; s/~A/~A/g'" + file + (regexp-quote old-version) new-version + old-hash + (or new-hash "new hash not available, check the log")))) + (format #t "running `~A'...~%" cmd) + (system cmd))) + + +;;; +;;; FTP client. +;;; + +(define-record-type + (%make-ftp-connection socket addrinfo) + ftp-connection? + (socket ftp-connection-socket) + (addrinfo ftp-connection-addrinfo)) + +(define %ftp-ready-rx + (make-regexp "^([0-9]{3}) (.+)$")) + +(define (%ftp-listen port) + (let loop ((line (read-line port))) + (cond ((eof-object? line) (values line #f)) + ((regexp-exec %ftp-ready-rx line) + => + (lambda (match) + (values (string->number (match:substring match 1)) + (match:substring match 2)))) + (else + (loop (read-line port)))))) + +(define (%ftp-command command expected-code port) + (format port "~A~A~A" command (string #\return) (string #\newline)) + (let-values (((code message) (%ftp-listen port))) + (if (eqv? code expected-code) + message + (throw 'ftp-error port command code message)))) + +(define (ftp-open host) + (catch 'getaddrinfo-error + (lambda () + (let* ((ai (car (getaddrinfo host "ftp"))) + (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) + (addrinfo:protocol ai)))) + (connect s (addrinfo:addr ai)) + (setvbuf s _IOLBF) + (let-values (((code message) (%ftp-listen s))) + (if (eqv? code 220) + (begin + ;(%ftp-command "OPTS UTF8 ON" 200 s) + ;; FIXME: When `USER' returns 331, we should do a `PASS email'. + (%ftp-command "USER anonymous" 230 s) + (%make-ftp-connection s ai)) + (begin + (format (current-error-port) "FTP to `~a' failed: ~A: ~A~%" + host code message) + (close s) + #f))))) + (lambda (key errcode) + (format (current-error-port) "failed to resolve `~a': ~a~%" + host (gai-strerror errcode)) + #f))) + +(define (ftp-close conn) + (close (ftp-connection-socket conn))) + +(define (ftp-chdir conn dir) + (%ftp-command (string-append "CWD " dir) 250 + (ftp-connection-socket conn))) + +(define (ftp-pasv conn) + (define %pasv-rx + (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)")) + + (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn)))) + (cond ((regexp-exec %pasv-rx message) + => + (lambda (match) + (+ (* (string->number (match:substring match 5)) 256) + (string->number (match:substring match 6))))) + (else + (throw 'ftp-error conn "PASV" 227 message))))) + + +(define (ftp-list conn) + (define (address-with-port sa port) + (let ((fam (sockaddr:fam sa)) + (addr (sockaddr:addr sa))) + (cond ((= fam AF_INET) + (make-socket-address fam addr port)) + ((= fam AF_INET6) + (make-socket-address fam addr port + (sockaddr:flowinfo sa) + (sockaddr:scopeid sa))) + (else #f)))) + + (let* ((port (ftp-pasv conn)) + (ai (ftp-connection-addrinfo conn)) + (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) + (addrinfo:protocol ai)))) + (connect s (address-with-port (addrinfo:addr ai) port)) + (setvbuf s _IOLBF) + + (dynamic-wind + (lambda () #t) + (lambda () + (%ftp-command "LIST" 150 (ftp-connection-socket conn)) + + (let loop ((line (read-line s)) + (result '())) + (cond ((eof-object? line) (reverse result)) + ((regexp-exec %ftp-ready-rx line) + => + (lambda (match) + (let ((code (string->number (match:substring match 1)))) + (if (= 126 code) + (reverse result) + (throw 'ftp-error conn "LIST" code))))) + (else + (loop (read-line s) + (let ((file (car (reverse (string-tokenize line))))) + (cons file result))))))) + (lambda () + (close s) + (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) + (or (eqv? code 226) + (throw 'ftp-error conn "LIST" code message))))))) + + +;;; +;;; GNU. +;;; + +(define %ignored-package-attributes + ;; Attribute name of packages to be ignored. + '("bash" "bashReal" "bashInteractive" ;; the full versioned name is incorrect + "autoconf213" + "automake17x" + "automake19x" + "automake110x" + "automake" ;; = 1.10.x + "bison1875" + "bison23" + "bison" ;; = 2.3 + "emacs22" + "emacsSnapshot" + "gcc295" + "gcc33" + "gcc34" + "gcc40" + "gcc41" + "gcc42" + "gcc43" + "glibc25" + "glibc27" + "glibc29" + "guile_1_9" + )) + +(define (gnu? package) + ;; Return true if PACKAGE (a snix expression) is a GNU package (according + ;; to a simple heuristic.) Otherwise return #f. + (match package + (('attribute _ attribute-name ('derivation _ _ body)) + (any (lambda (attr) + (match attr + (('attribute _ "meta" ('attribute-set metas)) + (any (lambda (attr) + (match attr + (('attribute _ "description" value) + (string-prefix? "GNU" value)) + (('attribute "homepage" value) + (string-contains value "www.gnu.org")) + (_ #f))) + metas)) + (_ #f))) + body)) + (_ #f))) + +(define (gnu-packages packages) + (fold (lambda (package gnu) + (match package + (('attribute _ "emacs23Packages" emacs-packages) + ;; XXX: Should prepend `emacs23Packages.' to attribute names. + (append (gnu-packages emacs-packages) gnu)) + (('attribute _ attribute-name ('derivation _ _ body)) + (if (member attribute-name %ignored-package-attributes) + gnu + (if (gnu? package) + (cons package gnu) + gnu))) + (_ gnu))) + '() + packages)) + +(define (ftp-server/directory project) + (define quirks + '(("libgcrypt" "ftp.gnupg.org" "/gcrypt" #t) + ("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t) + ("gnupg" "ftp.gnupg.org" "/gcrypt" #t) + ("gnu-ghostscript" "ftp.gnu.org" "/ghostscript" #f) + ("GNUnet" "ftp.gnu.org" "/gnu/gnunet" #f) + ("icecat" "ftp.gnu.org" "/gnu/gnuzilla" #f) + ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz" #f))) + + (let ((quirk (assoc project quirks))) + (match quirk + ((_ server directory subdir?) + (values server (if (not subdir?) + directory + (string-append directory "/" project)))) + (else + (values "ftp.gnu.org" (string-append "/gnu/" project)))))) + +(define (nixpkgs->gnu-name project) + (define quirks + '(("gcc-wrapper" . "gcc") + ("ghostscript" . "gnu-ghostscript") ;; ../ghostscript/gnu-ghoscript-X.Y.tar.gz + ("gnum4" . "m4") + ("gnugrep" . "grep") + ("gnused" . "sed") + ("gnutar" . "tar") + ("gnunet" . "GNUnet") ;; ftp.gnu.org/gnu/gnunet/GNUnet-x.y.tar.gz + ("texmacs" . "TeXmacs"))) + + (or (assoc-ref quirks project) project)) + +(define (releases project) + ;; TODO: Handle project release trees like that of IceCat and MyServer. + (define release-rx + (make-regexp (string-append "^" project "-[0-9].*\\.tar\\."))) + + (catch #t + (lambda () + (let-values (((server directory) (ftp-server/directory project))) + (let ((conn (ftp-open server))) + (ftp-chdir conn directory) + (let ((files (ftp-list conn))) + (ftp-close conn) + (map (lambda (tarball) + (let ((end (string-contains tarball ".tar"))) + (substring tarball 0 end))) + + ;; Filter out signatures, deltas, and files which are potentially + ;; not releases of PROJECT (e.g., in /gnu/guile, filter out + ;; guile-oops and guile-www). + (filter (lambda (file) + (and (not (string-suffix? ".sig" file)) + (regexp-exec release-rx file))) + files)))))) + (lambda (key subr message . args) + (format (current-error-port) + "failed to get release list for `~A': ~A ~A~%" + project message args) + '()))) + +(define version-string>? + (let ((strverscmp + (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) + (error "could not find `strverscmp' (from GNU libc)")))) + (make-foreign-function int sym (list '* '*)))) + (string->null-terminated-utf8 + (lambda (s) + (let* ((utf8 (string->utf8 s)) + (len (bytevector-length utf8)) + (nts (make-bytevector (+ len 1)))) + (bytevector-copy! utf8 0 nts 0 len) + (bytevector-u8-set! nts len 0) + nts)))) + (lambda (a b) + (let ((a (bytevector->foreign (string->null-terminated-utf8 a))) + (b (bytevector->foreign (string->null-terminated-utf8 b)))) + (> (strverscmp a b) 0))))) + +(define (latest-release project) + ;; Return "FOO-X.Y" or #f. + (let ((releases (releases project))) + (and (not (null? releases)) + (fold (lambda (release latest) + (if (version-string>? release latest) + release + latest)) + "" + releases)))) + +(define (package/version name+version) + (let ((hyphen (string-rindex name+version #\-))) + (if (not hyphen) + (values name+version #f) + (let ((name (substring name+version 0 hyphen)) + (version (substring name+version (+ hyphen 1) + (string-length name+version)))) + (values name version))))) + +(define (file-extension file) + (let ((dot (string-rindex file #\.))) + (and dot (substring file (+ 1 dot) (string-length file))))) + +(define (packages-to-update gnu-packages) + (fold (lambda (pkg result) + (call-with-package pkg + (lambda (attribute name+version location meta src) + (let-values (((name old-version) + (package/version name+version))) + (let ((latest (latest-release (nixpkgs->gnu-name name)))) + (cond ((not latest) + (format #t "~A [unknown latest version]~%" + name+version) + result) + ((string=? name+version latest) + (format #t "~A [up to date]~%" name+version) + result) + (else + (let-values (((project new-version) + (package/version latest)) + ((old-name old-hash old-urls) + (src->values src))) + (format #t "~A -> ~A [~A]~%" name+version latest + (and (pair? old-urls) (car old-urls))) + (let* ((url (and (pair? old-urls) + (car old-urls))) + (new-hash (fetch-gnu project new-version + (if url + (file-extension url) + "gz")))) + (cons (list name attribute + old-version old-hash + new-version new-hash + location) + result)))))))))) + '() + gnu-packages)) + +(define (fetch-gnu project version archive-type) + (let-values (((server directory) + (ftp-server/directory project))) + (let* ((base (string-append project "-" version ".tar." archive-type)) + (url (string-append "ftp://" server "/" directory "/" base)) + (sig (string-append base ".sig")) + (sig-url (string-append url ".sig"))) + (let-values (((hash path) (nix-prefetch-url url))) + (pk 'prefetch-url url hash path) + (and hash path + (begin + (false-if-exception (delete-file sig)) + (system* "wget" sig-url) + (if (file-exists? sig) + (let ((ret (system* "gpg" "--verify" sig path))) + (false-if-exception (delete-file sig)) + (if (and ret (= 0 (status:exit-val ret))) + hash + (begin + (format (current-error-port) + "signature verification failed for `~a'~%" + base) + (format (current-error-port) + "(could be because the public key is not in your keyring)~%") + #f))) + (begin + (format (current-error-port) + "no signature for `~a'~%" base) + hash)))))))) + + +;;; +;;; Main program. +;;; + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\h "help") #f #f + (lambda (opt name arg result) + (format #t "Usage: gnupdate [OPTIONS...]~%") + (format #t "GNUpdate -- update Nix expressions of GNU packages in Nixpkgs~%") + (format #t "~%") + (format #t " -x, --xml=FILE Read XML output of `nix-instantiate'~%") + (format #t " from FILE.~%") + (format #t " -s, --sxml=FILE Read SXML output of `nix-instantiate'~%") + (format #t " from FILE.~%") + (format #t " -h, --help Give this help list.~%~%") + (format #t "Report bugs to ~%") + (exit 0))) + + (option '(#\x "xml") #t #f + (lambda (opt name arg result) + (alist-cons 'xml-file arg result))) + (option '(#\s "sxml") #t #f + (lambda (opt name arg result) + (alist-cons 'sxml-file arg result))))) + +(define (main . args) + ;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs. + (let* ((opts (args-fold args %options + (lambda (opt name arg result) + (error "unrecognized option `~A'" name)) + (lambda (operand result) + (error "extraneous argument `~A'" operand)) + '())) + (home (getenv "HOME")) + (path (or (getenv "NIXPKGS") + (string-append home "/src/nixpkgs"))) + (sxml (or (and=> (assoc-ref opts 'sxml-file) + (lambda (input) + (format (current-error-port) + "reading SXML...~%") + (read-disable 'positions) ;; reduce memory usage + (with-input-from-file input read))) + (begin + (format (current-error-port) "parsing XML...~%") + (xml->sxml + (or (and=> (assoc-ref opts 'xml-file) + open-input-file) + (open-nixpkgs path)))))) + (snix (let ((s (begin + (format (current-error-port) + "producing SNix tree...~%") + (sxml->snix sxml)))) + (set! sxml #f) (gc) + s)) + (packages (match snix + (('snix _ ('attribute-set attributes)) + attributes) + (else #f))) + (gnu (gnu-packages packages)) + (updates (packages-to-update gnu))) + (format #t "~%~A packages to update...~%" (length updates)) + (for-each (lambda (update) + (match update + ((name attribute + old-version old-hash + new-version new-hash + location) + (update-nix-expression (location-file location) + old-version old-hash + new-version new-hash)) + (_ #f))) + updates))) diff --git a/maintainers/scripts/gnu/sxml-match.scm b/maintainers/scripts/gnu/sxml-match.scm new file mode 100644 index 000000000000..48d8c91b4b1f --- /dev/null +++ b/maintainers/scripts/gnu/sxml-match.scm @@ -0,0 +1,1227 @@ +;; Library: sxml-match +;; Author: Jim Bender +;; Version: 1.1, version for PLT Scheme +;; +;; Copyright 2005-9, Jim Bender +;; sxml-match is released under the MIT License +;; + +(define-module (sxml-match) + #:export (sxml-match + sxml-match-let + sxml-match-let*) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11)) + + +;;; +;;; PLT compatibility layer. +;;; + +(define-syntax syntax-object->datum + (syntax-rules () + ((_ stx) + (syntax->datum stx)))) + +(define-syntax void + (syntax-rules () + ((_) *unspecified*))) + +(define-syntax call/ec + ;; aka. `call-with-escape-continuation' + (syntax-rules () + ((_ proc) + (let ((prompt (gensym))) + (call-with-prompt prompt + (lambda () + (proc (lambda args + (apply abort-to-prompt + prompt args)))) + (lambda (k . args) + (apply values args))))))) + +(define-syntax let/ec + (syntax-rules () + ((_ cont body ...) + (call/ec (lambda (cont) body ...))))) + +(define (raise-syntax-error x msg obj sub) + (throw 'sxml-match-error x msg obj sub)) + + +;;; +;;; Body, unmodified from +;;; http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/sxml-match.ss +;;; except for: +;;; +;;; 1. The PLT-specific `module' form. +;;; +;;; 2. In `sxml-match1', ESCAPE is called with `call-with-values' instead +;;; of being called "normally", such that the example below returns the +;;; values `x' and `y' instead of just `x': +;;; +;;; (sxml-match '(foo) ((bar) (values 'p 'q)) ((foo) (values 'x 'y))) +;;; + +(define (nodeset? x) + (or (and (pair? x) (not (symbol? (car x)))) (null? x))) + +(define (xml-element-tag s) + (if (and (pair? s) (symbol? (car s))) + (car s) + (error 'xml-element-tag "expected an xml-element, given" s))) + +(define (xml-element-attributes s) + (if (and (pair? s) (symbol? (car s))) + (fold-right (lambda (a b) + (if (and (pair? a) (eq? '@ (car a))) + (if (null? b) + (filter (lambda (i) (not (and (pair? i) (eq? '@ (car i))))) (cdr a)) + (fold-right (lambda (c d) + (if (and (pair? c) (eq? '@ (car c))) + d + (cons c d))) + b (cdr a))) + b)) + '() + (cdr s)) + (error 'xml-element-attributes "expected an xml-element, given" s))) + +(define (xml-element-contents s) + (if (and (pair? s) (symbol? (car s))) + (filter (lambda (i) + (not (and (pair? i) (eq? '@ (car i))))) + (cdr s)) + (error 'xml-element-contents "expected an xml-element, given" s))) + +(define (match-xml-attribute key l) + (if (not (pair? l)) + #f + (if (eq? (car (car l)) key) + (car l) + (match-xml-attribute key (cdr l))))) + +(define (filter-attributes keys lst) + (if (null? lst) + '() + (if (member (caar lst) keys) + (filter-attributes keys (cdr lst)) + (cons (car lst) (filter-attributes keys (cdr lst)))))) + +(define-syntax compile-clause + (lambda (stx) + (letrec + ([sxml-match-syntax-error + (lambda (msg exp sub) + (raise-syntax-error #f msg (with-syntax ([s exp]) (syntax (sxml-match s))) sub))] + [ellipsis? + (lambda (stx) + (and (identifier? stx) (eq? '... (syntax->datum stx))))] + [literal? + (lambda (stx) + (let ([x (syntax->datum stx)]) + (or (string? x) + (char? x) + (number? x) + (boolean? x))))] + [keyword? + (lambda (stx) + (and (identifier? stx) + (let ([str (symbol->string (syntax->datum stx))]) + (char=? #\: (string-ref str (- (string-length str) 1))))))] + [extract-cata-fun + (lambda (cf) + (syntax-case cf () + [#f #f] + [other cf]))] + [add-pat-var + (lambda (pvar pvar-lst) + (define (check-pvar lst) + (if (null? lst) + (void) + (if (bound-identifier=? (car lst) pvar) + (sxml-match-syntax-error "duplicate pattern variable not allowed" + stx + pvar) + (check-pvar (cdr lst))))) + (check-pvar pvar-lst) + (cons pvar pvar-lst))] + [add-cata-def + (lambda (depth cvars cfun ctemp cdefs) + (cons (list depth cvars cfun ctemp) cdefs))] + [process-cata-exp + (lambda (depth cfun ctemp) + (if (= depth 0) + (with-syntax ([cf cfun] + [ct ctemp]) + (syntax (cf ct))) + (let ([new-ctemp (car (generate-temporaries (list ctemp)))]) + (with-syntax ([ct ctemp] + [nct new-ctemp] + [body (process-cata-exp (- depth 1) cfun new-ctemp)]) + (syntax (map (lambda (nct) body) ct))))))] + [process-cata-defs + (lambda (cata-defs body) + (if (null? cata-defs) + body + (with-syntax ([(cata-binding ...) + (map (lambda (def) + (with-syntax ([bvar (cadr def)] + [bval (process-cata-exp (car def) + (caddr def) + (cadddr def))]) + (syntax (bvar bval)))) + cata-defs)] + [body-stx body]) + (syntax (let-values (cata-binding ...) + body-stx)))))] + [cata-defs->pvar-lst + (lambda (lst) + (if (null? lst) + '() + (let iter ([items (cadr (car lst))]) + (syntax-case items () + [() (cata-defs->pvar-lst (cdr lst))] + [(fst . rst) (cons (syntax fst) (iter (syntax rst)))]))))] + [process-output-action + (lambda (action dotted-vars) + (define (finite-lst? lst) + (syntax-case lst () + (item + (identifier? (syntax item)) + #f) + (() + #t) + ((fst dots . rst) + (ellipsis? (syntax dots)) + #f) + ((fst . rst) + (finite-lst? (syntax rst))))) + (define (expand-lst lst) + (syntax-case lst () + [() (syntax '())] + [item + (identifier? (syntax item)) + (syntax item)] + [(fst dots . rst) + (ellipsis? (syntax dots)) + (with-syntax ([exp-lft (expand-dotted-item + (process-output-action (syntax fst) + dotted-vars))] + [exp-rgt (expand-lst (syntax rst))]) + (syntax (append exp-lft exp-rgt)))] + [(fst . rst) + (with-syntax ([exp-lft (process-output-action (syntax fst) + dotted-vars)] + [exp-rgt (expand-lst (syntax rst))]) + (syntax (cons exp-lft exp-rgt)))])) + (define (member-var? var lst) + (let iter ([lst lst]) + (if (null? lst) + #f + (if (or (bound-identifier=? var (car lst)) + (free-identifier=? var (car lst))) + #t + (iter (cdr lst)))))) + (define (dotted-var? var) + (member-var? var dotted-vars)) + (define (merge-pvars lst1 lst2) + (if (null? lst1) + lst2 + (if (member-var? (car lst1) lst2) + (merge-pvars (cdr lst1) lst2) + (cons (car lst1) (merge-pvars (cdr lst1) lst2))))) + (define (select-dotted-vars x) + (define (walk-quasi-body y) + (syntax-case y (unquote unquote-splicing) + [((unquote a) . rst) + (merge-pvars (select-dotted-vars (syntax a)) + (walk-quasi-body (syntax rst)))] + [((unquote-splicing a) . rst) + (merge-pvars (select-dotted-vars (syntax a)) + (walk-quasi-body (syntax rst)))] + [(fst . rst) + (merge-pvars (walk-quasi-body (syntax fst)) + (walk-quasi-body (syntax rst)))] + [other + '()])) + (syntax-case x (quote quasiquote) + [(quote . rst) '()] + [(quasiquote . rst) (walk-quasi-body (syntax rst))] + [(fst . rst) + (merge-pvars (select-dotted-vars (syntax fst)) + (select-dotted-vars (syntax rst)))] + [item + (and (identifier? (syntax item)) + (dotted-var? (syntax item))) + (list (syntax item))] + [item '()])) + (define (expand-dotted-item item) + (let ([dvars (select-dotted-vars item)]) + (syntax-case item () + [x + (identifier? (syntax x)) + (syntax x)] + [x (with-syntax ([(dv ...) dvars]) + (syntax (map (lambda (dv ...) x) dv ...)))]))) + (define (expand-quasiquote-body x) + (syntax-case x (unquote unquote-splicing quasiquote) + [(quasiquote . rst) (process-quasiquote x)] + [(unquote item) + (with-syntax ([expanded-item (process-output-action (syntax item) + dotted-vars)]) + (syntax (unquote expanded-item)))] + [(unquote-splicing item) + (with-syntax ([expanded-item (process-output-action (syntax item) + dotted-vars)]) + (syntax (unquote-splicing expanded-item)))] + [((unquote item) dots . rst) + (ellipsis? (syntax dots)) + (with-syntax ([expanded-item (expand-dotted-item + (process-output-action (syntax item) + dotted-vars))] + [expanded-rst (expand-quasiquote-body (syntax rst))]) + (syntax ((unquote-splicing expanded-item) . expanded-rst)))] + [(item dots . rst) + (ellipsis? (syntax dots)) + (with-syntax ([expanded-item (expand-dotted-item + (process-output-action (syntax (quasiquote item)) + dotted-vars))] + [expanded-rst (expand-quasiquote-body (syntax rst))]) + (syntax ((unquote-splicing expanded-item) . expanded-rst)))] + [(fst . rst) + (with-syntax ([expanded-fst (expand-quasiquote-body (syntax fst))] + [expanded-rst (expand-quasiquote-body (syntax rst))]) + (syntax (expanded-fst . expanded-rst)))] + [other x])) + (define (process-quasiquote x) + (syntax-case x () + [(quasiquote term) (with-syntax ([expanded-body (expand-quasiquote-body (syntax term))]) + (syntax (quasiquote expanded-body)))] + [else (sxml-match-syntax-error "bad quasiquote-form" + stx + x)])) + (syntax-case action (quote quasiquote) + [(quote . rst) action] + [(quasiquote . rst) (process-quasiquote action)] + [(fst . rst) (if (finite-lst? action) + (with-syntax ([exp-lft (process-output-action (syntax fst) dotted-vars)] + [exp-rgt (process-output-action (syntax rst) dotted-vars)]) + (syntax (exp-lft . exp-rgt))) + (with-syntax ([exp-lft (process-output-action (syntax fst) + dotted-vars)] + [exp-rgt (expand-lst (syntax rst))]) + (syntax (apply exp-lft exp-rgt))))] + [item action]))] + [compile-element-pat + (lambda (ele exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars) + (syntax-case ele (@) + [(tag (@ . attr-items) . items) + (identifier? (syntax tag)) + (let ([attr-exp (car (generate-temporaries (list exp)))] + [body-exp (car (generate-temporaries (list exp)))]) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax attr-items) + (syntax items) + attr-exp + body-exp + '() + nextp + fail-k + pvar-lst + depth + cata-fun + cata-defs + dotted-vars)]) + (values (with-syntax ([x exp] + [ax attr-exp] + [bx body-exp] + [body tests] + [fail-to fail-k]) + (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x))) + (let ([ax (xml-element-attributes x)] + [bx (xml-element-contents x)]) + body) + (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [(tag . items) + (identifier? (syntax tag)) + (let ([body-exp (car (generate-temporaries (list exp)))]) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-item-list (syntax items) + body-exp + nextp + fail-k + #t + pvar-lst + depth + cata-fun + cata-defs + dotted-vars)]) + (values (with-syntax ([x exp] + [bx body-exp] + [body tests] + [fail-to fail-k]) + (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x))) + (let ([bx (xml-element-contents x)]) + body) + (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))]))] + [compile-end-element + (lambda (exp nextp fail-k pvar-lst cata-defs dotted-vars) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp pvar-lst cata-defs dotted-vars)]) + (values (with-syntax ([x exp] + [body next-tests] + [fail-to fail-k]) + (syntax (if (null? x) body (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [compile-attr-list + (lambda (attr-lst body-lst attr-exp body-exp attr-key-lst nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars) + (syntax-case attr-lst (unquote ->) + [(unquote var) + (identifier? (syntax var)) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-item-list body-lst + body-exp + nextp + fail-k + #t + (add-pat-var (syntax var) pvar-lst) + depth + cata-fun + cata-defs + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [matched-attrs attr-key-lst] + [body tests]) + (syntax (let ([var (filter-attributes 'matched-attrs ax)]) + body))) + new-pvar-lst + new-cata-defs + new-dotted-vars))] + [((atag [(unquote [cata -> cvar ...]) default]) . rst) + (identifier? (syntax atag)) + (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax rst) + body-lst + attr-exp + body-exp + (cons (syntax atag) attr-key-lst) + nextp + fail-k + (add-pat-var ctemp pvar-lst) + depth + cata-fun + (add-cata-def depth + (syntax [cvar ...]) + (syntax cata) + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [ct ctemp] + [body tests]) + (syntax (let ([binding (match-xml-attribute 'atag ax)]) + (let ([ct (if binding + (cadr binding) + default)]) + body)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [((atag [(unquote [cvar ...]) default]) . rst) + (identifier? (syntax atag)) + (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (if (not cata-fun) + (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" + stx + (syntax [cvar ...]))) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax rst) + body-lst + attr-exp + body-exp + (cons (syntax atag) attr-key-lst) + nextp + fail-k + (add-pat-var ctemp pvar-lst) + depth + cata-fun + (add-cata-def depth + (syntax [cvar ...]) + cata-fun + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [ct ctemp] + [body tests]) + (syntax (let ([binding (match-xml-attribute 'atag ax)]) + (let ([ct (if binding + (cadr binding) + default)]) + body)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [((atag [(unquote var) default]) . rst) + (and (identifier? (syntax atag)) (identifier? (syntax var))) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax rst) + body-lst + attr-exp + body-exp + (cons (syntax atag) attr-key-lst) + nextp + fail-k + (add-pat-var (syntax var) pvar-lst) + depth + cata-fun + cata-defs + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [body tests]) + (syntax (let ([binding (match-xml-attribute 'atag ax)]) + (let ([var (if binding + (cadr binding) + default)]) + body)))) + new-pvar-lst + new-cata-defs + new-dotted-vars))] + [((atag (unquote [cata -> cvar ...])) . rst) + (identifier? (syntax atag)) + (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax rst) + body-lst + attr-exp + body-exp + (cons (syntax atag) attr-key-lst) + nextp + fail-k + (add-pat-var ctemp pvar-lst) + depth + cata-fun + (add-cata-def depth + (syntax [cvar ...]) + (syntax cata) + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [ct ctemp] + [body tests] + [fail-to fail-k]) + (syntax (let ([binding (match-xml-attribute 'atag ax)]) + (if binding + (let ([ct (cadr binding)]) + body) + (fail-to))))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [((atag (unquote [cvar ...])) . rst) + (identifier? (syntax atag)) + (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (if (not cata-fun) + (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" + stx + (syntax [cvar ...]))) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax rst) + body-lst + attr-exp + body-exp + (cons (syntax atag) attr-key-lst) + nextp + fail-k + (add-pat-var ctemp pvar-lst) + depth + cata-fun + (add-cata-def depth + (syntax [cvar ...]) + cata-fun + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [ct ctemp] + [body tests] + [fail-to fail-k]) + (syntax (let ([binding (match-xml-attribute 'atag ax)]) + (if binding + (let ([ct (cadr binding)]) + body) + (fail-to))))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [((atag (unquote var)) . rst) + (and (identifier? (syntax atag)) (identifier? (syntax var))) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax rst) + body-lst + attr-exp + body-exp + (cons (syntax atag) attr-key-lst) + nextp + fail-k + (add-pat-var (syntax var) pvar-lst) + depth + cata-fun + cata-defs + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [body tests] + [fail-to fail-k]) + (syntax (let ([binding (match-xml-attribute 'atag ax)]) + (if binding + (let ([var (cadr binding)]) + body) + (fail-to))))) + new-pvar-lst + new-cata-defs + new-dotted-vars))] + [((atag (i ...)) . rst) + (identifier? (syntax atag)) + (sxml-match-syntax-error "bad attribute pattern" + stx + (syntax (kwd (i ...))))] + [((atag i) . rst) + (and (identifier? (syntax atag)) (identifier? (syntax i))) + (sxml-match-syntax-error "bad attribute pattern" + stx + (syntax (kwd i)))] + [((atag literal) . rst) + (and (identifier? (syntax atag)) (literal? (syntax literal))) + (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) + (compile-attr-list (syntax rst) + body-lst + attr-exp + body-exp + (cons (syntax atag) attr-key-lst) + nextp + fail-k + pvar-lst + depth + cata-fun + cata-defs + dotted-vars)]) + (values (with-syntax ([ax attr-exp] + [body tests] + [fail-to fail-k]) + (syntax (let ([binding (match-xml-attribute 'atag ax)]) + (if binding + (if (equal? (cadr binding) literal) + body + (fail-to)) + (fail-to))))) + new-pvar-lst + new-cata-defs + new-dotted-vars))] + [() + (compile-item-list body-lst + body-exp + nextp + fail-k + #t + pvar-lst + depth + cata-fun + cata-defs + dotted-vars)]))] + [compile-item-list + (lambda (lst exp nextp fail-k ellipsis-allowed? pvar-lst depth cata-fun cata-defs dotted-vars) + (syntax-case lst (unquote ->) + [() (compile-end-element exp nextp fail-k pvar-lst cata-defs dotted-vars)] + [(unquote var) + (identifier? (syntax var)) + (if (not ellipsis-allowed?) + (sxml-match-syntax-error "improper list pattern not allowed in this context" + stx + (syntax dots)) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)]) + (values (with-syntax ([x exp] + [body next-tests]) + (syntax (let ([var x]) body))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [(unquote [cata -> cvar ...]) + (if (not ellipsis-allowed?) + (sxml-match-syntax-error "improper list pattern not allowed in this context" + stx + (syntax dots)) + (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp (add-pat-var ctemp pvar-lst) + (add-cata-def depth + (syntax [cvar ...]) + (syntax cata) + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([ct ctemp] + [x exp] + [body next-tests]) + (syntax (let ([ct x]) body))) + new-pvar-lst + new-cata-defs + new-dotted-vars))))] + [(unquote [cvar ...]) + (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (if (not cata-fun) + (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" + stx + (syntax [cvar ...]))) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp (add-pat-var ctemp pvar-lst) + (add-cata-def depth + (syntax [cvar ...]) + cata-fun + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([ct ctemp] + [x exp] + [body next-tests]) + (syntax (let ([ct x]) body))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [(item dots . rst) + (ellipsis? (syntax dots)) + (if (not ellipsis-allowed?) + (sxml-match-syntax-error "ellipses not allowed in this context" + stx + (syntax dots)) + (compile-dotted-pattern-list (syntax item) + (syntax rst) + exp + nextp + fail-k + pvar-lst + depth + cata-fun + cata-defs + dotted-vars))] + [(item . rst) + (compile-item (syntax item) + exp + (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars) + (compile-item-list (syntax rst) + new-exp + nextp + fail-k + ellipsis-allowed? + new-pvar-lst + depth + cata-fun + new-cata-defs + new-dotted-vars)) + fail-k + pvar-lst + depth + cata-fun + cata-defs + dotted-vars)]))] + [compile-dotted-pattern-list + (lambda (item + tail + exp + nextp + fail-k + pvar-lst + depth + cata-fun + cata-defs + dotted-vars) + (let-values ([(tail-tests tail-pvar-lst tail-cata-defs tail-dotted-vars) + (compile-item-list tail + (syntax lst) + (lambda (new-pvar-lst new-cata-defs new-dotted-vars) + (values (with-syntax ([(npv ...) new-pvar-lst]) + (syntax (values #t npv ...))) + new-pvar-lst + new-cata-defs + new-dotted-vars)) + (syntax fail) + #f + '() + depth + '() + '() + dotted-vars)] + [(item-tests item-pvar-lst item-cata-defs item-dotted-vars) + (compile-item item + (syntax lst) + (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars) + (values (with-syntax ([(npv ...) new-pvar-lst]) + (syntax (values #t (cdr lst) npv ...))) + new-pvar-lst + new-cata-defs + new-dotted-vars)) + (syntax fail) + '() + (+ 1 depth) + cata-fun + '() + dotted-vars)]) + ; more here: check for duplicate pat-vars, cata-defs + (let-values ([(final-tests final-pvar-lst final-cata-defs final-dotted-vars) + (nextp (append tail-pvar-lst item-pvar-lst pvar-lst) + (append tail-cata-defs item-cata-defs cata-defs) + (append item-pvar-lst + (cata-defs->pvar-lst item-cata-defs) + tail-dotted-vars + dotted-vars))]) + (let ([temp-item-pvar-lst (generate-temporaries item-pvar-lst)]) + (values + (with-syntax + ([x exp] + [fail-to fail-k] + [tail-body tail-tests] + [item-body item-tests] + [final-body final-tests] + [(ipv ...) item-pvar-lst] + [(gpv ...) temp-item-pvar-lst] + [(tpv ...) tail-pvar-lst] + [(item-void ...) (map (lambda (i) (syntax (void))) item-pvar-lst)] + [(tail-void ...) (map (lambda (i) (syntax (void))) tail-pvar-lst)] + [(item-null ...) (map (lambda (i) (syntax '())) item-pvar-lst)] + [(item-cons ...) (map (lambda (a b) + (with-syntax ([xa a] + [xb b]) + (syntax (cons xa xb)))) + item-pvar-lst + temp-item-pvar-lst)]) + (syntax (letrec ([match-tail + (lambda (lst fail) + tail-body)] + [match-item + (lambda (lst) + (let ([fail (lambda () + (values #f + lst + item-void ...))]) + item-body))] + [match-dotted + (lambda (x) + (let-values ([(tail-res tpv ...) + (match-tail x + (lambda () + (values #f + tail-void ...)))]) + (if tail-res + (values item-null ... + tpv ...) + (let-values ([(res new-x ipv ...) (match-item x)]) + (if res + (let-values ([(gpv ... tpv ...) + (match-dotted new-x)]) + (values item-cons ... tpv ...)) + (let-values ([(last-tail-res tpv ...) + (match-tail x fail-to)]) + (values item-null ... tpv ...)))))))]) + (let-values ([(ipv ... tpv ...) + (match-dotted x)]) + final-body)))) + final-pvar-lst + final-cata-defs + final-dotted-vars)))))] + [compile-item + (lambda (item exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars) + (syntax-case item (unquote ->) + ; normal pattern var + [(unquote var) + (identifier? (syntax var)) + (let ([new-exp (car (generate-temporaries (list exp)))]) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp new-exp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)]) + (values (with-syntax ([x exp] + [nx new-exp] + [body next-tests] + [fail-to fail-k]) + (syntax (if (pair? x) + (let ([nx (cdr x)] + [var (car x)]) + body) + (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + ; named catamorphism + [(unquote [cata -> cvar ...]) + (let ([new-exp (car (generate-temporaries (list exp)))] + [ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp new-exp + (add-pat-var ctemp pvar-lst) + (add-cata-def depth + (syntax [cvar ...]) + (syntax cata) + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([x exp] + [nx new-exp] + [ct ctemp] + [body next-tests] + [fail-to fail-k]) + (syntax (if (pair? x) + (let ([nx (cdr x)] + [ct (car x)]) + body) + (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + ; basic catamorphism + [(unquote [cvar ...]) + (let ([new-exp (car (generate-temporaries (list exp)))] + [ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) + (if (not cata-fun) + (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" + stx + (syntax [cvar ...]))) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp new-exp + (add-pat-var ctemp pvar-lst) + (add-cata-def depth + (syntax [cvar ...]) + cata-fun + ctemp + cata-defs) + dotted-vars)]) + (values (with-syntax ([x exp] + [nx new-exp] + [ct ctemp] + [body next-tests] + [fail-to fail-k]) + (syntax (if (pair? x) + (let ([nx (cdr x)] + [ct (car x)]) + body) + (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))] + [(tag item ...) + (identifier? (syntax tag)) + (let ([new-exp (car (generate-temporaries (list exp)))]) + (let-values ([(after-tests after-pvar-lst after-cata-defs after-dotted-vars) + (compile-element-pat (syntax (tag item ...)) + (with-syntax ([x exp]) + (syntax (car x))) + (lambda (more-pvar-lst more-cata-defs more-dotted-vars) + (let-values ([(next-tests new-pvar-lst + new-cata-defs + new-dotted-vars) + (nextp new-exp + more-pvar-lst + more-cata-defs + more-dotted-vars)]) + (values (with-syntax ([x exp] + [nx new-exp] + [body next-tests]) + (syntax (let ([nx (cdr x)]) + body))) + new-pvar-lst + new-cata-defs + new-dotted-vars))) + fail-k + pvar-lst + depth + cata-fun + cata-defs + dotted-vars)]) + ; test that we are not at the end of an item-list, BEFORE + ; entering tests for the element pattern (against the 'car' of the item-list) + (values (with-syntax ([x exp] + [body after-tests] + [fail-to fail-k]) + (syntax (if (pair? x) + body + (fail-to)))) + after-pvar-lst + after-cata-defs + after-dotted-vars)))] + [(i ...) + (sxml-match-syntax-error "bad pattern syntax (not an element pattern)" + stx + (syntax (i ...)))] + [i + (identifier? (syntax i)) + (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)" + stx + (syntax i))] + [literal + (literal? (syntax literal)) + (let ([new-exp (car (generate-temporaries (list exp)))]) + (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) + (nextp new-exp pvar-lst cata-defs dotted-vars)]) + (values (with-syntax ([x exp] + [nx new-exp] + [body next-tests] + [fail-to fail-k]) + (syntax (if (and (pair? x) (equal? literal (car x))) + (let ([nx (cdr x)]) + body) + (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)))]))]) + (let ([fail-k (syntax failure)]) + (syntax-case stx (unquote guard ->) + [(compile-clause ((unquote var) (guard gexp ...) action0 action ...) + exp + cata-fun + fail-exp) + (identifier? (syntax var)) + (syntax (let ([var exp]) + (if (and gexp ...) + (begin action0 action ...) + (fail-exp))))] + [(compile-clause ((unquote [cata -> cvar ...]) (guard gexp ...) action0 action ...) + exp + cata-fun + fail-exp) + (syntax (if (and gexp ...) + (let-values ([(cvar ...) (cata exp)]) + (begin action0 action ...)) + (fail-exp)))] + [(compile-clause ((unquote [cvar ...]) (guard gexp ...) action0 action ...) + exp + cata-fun + fail-exp) + (if (not (extract-cata-fun (syntax cata-fun))) + (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" + stx + (syntax [cvar ...])) + (syntax (if (and gexp ...) + (let-values ([(cvar ...) (cata-fun exp)]) + (begin action0 action ...)) + (fail-exp))))] + [(compile-clause ((unquote var) action0 action ...) exp cata-fun fail-exp) + (identifier? (syntax var)) + (syntax (let ([var exp]) + action0 action ...))] + [(compile-clause ((unquote [cata -> cvar ...]) action0 action ...) exp cata-fun fail-exp) + (syntax (let-values ([(cvar ...) (cata exp)]) + action0 action ...))] + [(compile-clause ((unquote [cvar ...]) action0 action ...) exp cata-fun fail-exp) + (if (not (extract-cata-fun (syntax cata-fun))) + (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" + stx + (syntax [cvar ...])) + (syntax (let-values ([(cvar ...) (cata-fun exp)]) + action0 action ...)))] + [(compile-clause ((lst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp) + (and (identifier? (syntax lst)) (eq? 'list (syntax->datum (syntax lst)))) + (let-values ([(result pvar-lst cata-defs dotted-vars) + (compile-item-list (syntax rst) + (syntax exp) + (lambda (new-pvar-lst new-cata-defs new-dotted-vars) + (values + (with-syntax + ([exp-body (process-cata-defs new-cata-defs + (process-output-action + (syntax (begin action0 + action ...)) + new-dotted-vars))] + [fail-to fail-k]) + (syntax (if (and gexp ...) exp-body (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)) + fail-k + #t + '() + 0 + (extract-cata-fun (syntax cata-fun)) + '() + '())]) + (with-syntax ([fail-to fail-k] + [body result]) + (syntax (let ([fail-to fail-exp]) + (if (nodeset? exp) + body + (fail-to))))))] + [(compile-clause ((lst . rst) action0 action ...) exp cata-fun fail-exp) + (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst)))) + (let-values ([(result pvar-lst cata-defs dotted-vars) + (compile-item-list (syntax rst) + (syntax exp) + (lambda (new-pvar-lst new-cata-defs new-dotted-vars) + (values (process-cata-defs new-cata-defs + (process-output-action + (syntax (begin action0 + action ...)) + new-dotted-vars)) + new-pvar-lst + new-cata-defs + new-dotted-vars)) + fail-k + #t + '() + 0 + (extract-cata-fun (syntax cata-fun)) + '() + '())]) + (with-syntax ([body result] + [fail-to fail-k]) + (syntax (let ([fail-to fail-exp]) + (if (nodeset? exp) + body + (fail-to))))))] + [(compile-clause ((fst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp) + (identifier? (syntax fst)) + (let-values ([(result pvar-lst cata-defs dotted-vars) + (compile-element-pat (syntax (fst . rst)) + (syntax exp) + (lambda (new-pvar-lst new-cata-defs new-dotted-vars) + (values + (with-syntax + ([body (process-cata-defs new-cata-defs + (process-output-action + (syntax (begin action0 + action ...)) + new-dotted-vars))] + [fail-to fail-k]) + (syntax (if (and gexp ...) body (fail-to)))) + new-pvar-lst + new-cata-defs + new-dotted-vars)) + fail-k + '() + 0 + (extract-cata-fun (syntax cata-fun)) + '() + '())]) + (with-syntax ([fail-to fail-k] + [body result]) + (syntax (let ([fail-to fail-exp]) + body))))] + [(compile-clause ((fst . rst) action0 action ...) exp cata-fun fail-exp) + (identifier? (syntax fst)) + (let-values ([(result pvar-lst cata-defs dotted-vars) + (compile-element-pat (syntax (fst . rst)) + (syntax exp) + (lambda (new-pvar-lst new-cata-defs new-dotted-vars) + (values (process-cata-defs new-cata-defs + (process-output-action + (syntax (begin action0 + action ...)) + new-dotted-vars)) + new-pvar-lst + new-cata-defs + new-dotted-vars)) + fail-k + '() + 0 + (extract-cata-fun (syntax cata-fun)) + '() + '())]) + (with-syntax ([fail-to fail-k] + [body result]) + (syntax (let ([fail-to fail-exp]) + body))))] + [(compile-clause ((i ...) (guard gexp ...) action0 action ...) exp cata-fun fail-exp) + (sxml-match-syntax-error "bad pattern syntax (not an element pattern)" + stx + (syntax (i ...)))] + [(compile-clause ((i ...) action0 action ...) exp cata-fun fail-exp) + (sxml-match-syntax-error "bad pattern syntax (not an element pattern)" + stx + (syntax (i ...)))] + [(compile-clause (pat (guard gexp ...) action0 action ...) exp cata-fun fail-exp) + (identifier? (syntax pat)) + (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)" + stx + (syntax pat))] + [(compile-clause (pat action0 action ...) exp cata-fun fail-exp) + (identifier? (syntax pat)) + (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)" + stx + (syntax pat))] + [(compile-clause (literal (guard gexp ...) action0 action ...) exp cata-fun fail-exp) + (literal? (syntax literal)) + (syntax (if (and (equal? literal exp) (and gexp ...)) + (begin action0 action ...) + (fail-exp)))] + [(compile-clause (literal action0 action ...) exp cata-fun fail-exp) + (literal? (syntax literal)) + (syntax (if (equal? literal exp) + (begin action0 action ...) + (fail-exp)))]))))) + +(define-syntax sxml-match1 + (syntax-rules () + [(sxml-match1 exp cata-fun clause) + (compile-clause clause exp cata-fun + (lambda () (error 'sxml-match "no matching clause found")))] + [(sxml-match1 exp cata-fun clause0 clause ...) + (let/ec escape + (compile-clause clause0 exp cata-fun + (lambda () (call-with-values + (lambda () (sxml-match1 exp cata-fun + clause ...)) + escape))))])) + +(define-syntax sxml-match + (syntax-rules () + ((sxml-match val clause0 clause ...) + (letrec ([cfun (lambda (exp) + (sxml-match1 exp cfun clause0 clause ...))]) + (cfun val))))) + +(define-syntax sxml-match-let1 + (syntax-rules () + [(sxml-match-let1 syntag synform () body0 body ...) + (let () body0 body ...)] + [(sxml-match-let1 syntag synform ([pat exp]) body0 body ...) + (compile-clause (pat (let () body0 body ...)) + exp + #f + (lambda () (error 'syntag "could not match pattern ~s" 'pat)))] + [(sxml-match-let1 syntag synform ([pat0 exp0] [pat exp] ...) body0 body ...) + (compile-clause (pat0 (sxml-match-let1 syntag synform ([pat exp] ...) body0 body ...)) + exp0 + #f + (lambda () (error 'syntag "could not match pattern ~s" 'pat0)))])) + +(define-syntax sxml-match-let-help + (lambda (stx) + (syntax-case stx () + [(sxml-match-let-help syntag synform ([pat exp] ...) body0 body ...) + (with-syntax ([(temp-name ...) (generate-temporaries (syntax (exp ...)))]) + (syntax (let ([temp-name exp] ...) + (sxml-match-let1 syntag synform ([pat temp-name] ...) body0 body ...))))]))) + +(define-syntax sxml-match-let + (lambda (stx) + (syntax-case stx () + [(sxml-match-let ([pat exp] ...) body0 body ...) + (with-syntax ([synform stx]) + (syntax (sxml-match-let-help sxml-match-let synform ([pat exp] ...) body0 body ...)))]))) + +(define-syntax sxml-match-let* + (lambda (stx) + (syntax-case stx () + [(sxml-match-let* () body0 body ...) + (syntax (let () body0 body ...))] + [(sxml-match-let* ([pat0 exp0] [pat exp] ...) body0 body ...) + (with-syntax ([synform stx]) + (syntax (sxml-match-let-help sxml-match-let* synform ([pat0 exp0]) + (sxml-match-let* ([pat exp] ...) + body0 body ...))))])))