validate.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2 ;;;
   3 ;;; An implementation of James Clark's algorithm for RELAX NG validation.
   4 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30
  31 (in-package :cxml-rng)
  32
  33 (defvar *empty* (make-empty))
  34 (defvar *not-allowed* (make-not-allowed))
  35
  36 (defmacro ensuref (key table value)
  37   `(ensure-hash ,key ,table (lambda () ,value)))
  38
  39 (defun ensure-hash (key table fn)
  40   (or (gethash key table)
  41       (setf (gethash key table) (funcall fn))))
  42
  43
  44 (defun make-validator (schema &optional handler)
  45   "@arg[schema]{the parsed Relax NG @class{schema} object}
  46    @arg[handler]{an additional SAX handler to broadcast events to}
  47    @return{a SAX handler}
  48    @short{This function creates a validation handler for @code{schema}},
  49     to be used for validation of a document against that schema.
  50
  51    The validation handler processes SAX events and can be used with any
  52    function generating such events, in particular with cxml:parse-file.
  53
  54    Events will be passed on unchanged to @code{handler}.
  55
  56    @see{parse-schema}
  57    @see{make-validating-source}"
  58   (let* ((table (ensure-registratur schema))
  59          (start (schema-interned-start schema))
  60          (validator
  61           (make-instance 'validator
  62                          :registratur table
  63                          :current-pattern start))
  64          (wrapper
  65           (make-instance 'text-normalizer :chained-handler validator)))
  66     (when handler
  67       (setf wrapper (cxml:make-broadcast-handler wrapper handler)))
  68     (values wrapper validator)))
  69
  70
  71 ;;;; CONTAINS
  72
  73 (defgeneric contains (nc uri lname))
  74
  75 (defmethod contains ((nc any-name) uri lname)
  76   (let ((except (any-name-except nc)))
  77     (if except
  78         (not (contains except uri lname))
  79         t)))
  80
  81 (defmethod contains ((nc ns-name) uri lname)
  82   (and (equal (ns-name-uri nc) uri)
  83        (let ((except (ns-name-except nc)))
  84          (if except
  85              (not (contains except uri lname))
  86              t))))
  87
  88 (defmethod contains ((nc name) uri lname)
  89   (and (equal (name-uri nc) uri)
  90        (equal (name-lname nc) lname)))
  91
  92 (defmethod contains ((nc name-class-choice) uri lname)
  93   (or (contains (name-class-choice-a nc) uri lname)
  94       (contains (name-class-choice-b nc) uri lname)))
  95
  96
  97 ;;;; COMPUTE-NULLABLE
  98
  99 (defun finalize-pattern (p)
 100   (setf (pattern-nullable p) (compute-nullable p))
 101   p)
 102
 103 (defun nullable (pattern)
 104   (let ((np (pattern-nullable pattern)))
 105     (check-type np boolean)             ;initialized by intern-pattern
 106     np))
 107
 108 (defgeneric compute-nullable (pattern))
 109
 110 (defmethod compute-nullable ((pattern group))
 111   (and (nullable (pattern-a pattern))
 112        (nullable (pattern-b pattern))))
 113
 114 (defmethod compute-nullable  ((pattern interleave))
 115   (and (nullable (pattern-a pattern))
 116        (nullable (pattern-b pattern))))
 117
 118 (defmethod compute-nullable ((pattern choice))
 119   (or (nullable (pattern-a pattern))
 120       (nullable (pattern-b pattern))))
 121
 122 (defmethod compute-nullable ((pattern one-or-more))
 123   (nullable (pattern-child pattern)))
 124
 125 (defmethod compute-nullable ((pattern element)) nil)
 126 (defmethod compute-nullable ((pattern attribute)) nil)
 127 (defmethod compute-nullable ((pattern list-pattern)) nil)
 128 (defmethod compute-nullable ((pattern value)) nil)
 129 (defmethod compute-nullable ((pattern data)) nil)
 130 (defmethod compute-nullable ((pattern not-allowed)) nil)
 131 (defmethod compute-nullable ((pattern after)) nil)
 132
 133 (defmethod compute-nullable ((pattern empty)) t)
 134 (defmethod compute-nullable ((pattern text)) t)
 135
 136
 137 ;;;; VALIDATOR
 138
 139 (defclass validator (sax:sax-parser-mixin
 140                      cxml-types:sax-validation-context-mixin)
 141   ((current-pattern :initarg :current-pattern :accessor current-pattern)
 142    (after-start-tag-p :accessor after-start-tag-p)
 143    (pending-text-node :initform nil :accessor pending-text-node)
 144    (registratur :initarg :registratur :accessor registratur)
 145    (validation-error-class :initform 'rng-error
 146                            :initarg :validation-error-class
 147                            :accessor validation-error-class)
 148    (open-start-tag\'-cache :initform (make-hash-table :test 'equal)
 149                            :reader open-start-tag\'-cache)
 150    (close-start-tag\'-cache :initform (make-hash-table)
 151                             :reader close-start-tag\'-cache)
 152    (end-tag\'-cache :initform (make-hash-table) :reader end-tag\'-cache)
 153    (non-element\'-cache :initform (make-hash-table)
 154                         :reader non-element\'-cache)
 155    (mixed-text\'-cache :initform (make-hash-table)
 156                        :reader mixed-text\'-cache)))
 157
 158 (defun advance (hsx pattern message &rest args)
 159   (when (typep pattern 'not-allowed)
 160     (let ((*error-class* (validation-error-class hsx)))
 161       (rng-error hsx "~?, was expecting ~A"
 162                  message
 163                  args
 164                  (replace-scary-characters
 165                   (with-output-to-string (s)
 166                     (let ((*print-level* nil))
 167                       (expectation (current-pattern hsx) s)))))))
 168   (setf (current-pattern hsx) pattern))
 169
 170 ;; make sure slime doesn't die
 171 (defun replace-scary-characters (pattern)
 172   (let ((str (write-to-string pattern
 173                               :circle t
 174                               :escape nil
 175                               :pretty nil)))
 176     (loop
 177        for c across str
 178        for i from 0
 179        when (>= (char-code c) 128)
 180        do (setf (elt str i) #\?))
 181     str))
 182
 183 (defmethod sax:characters ((hsx validator) data)
 184   (assert (null (pending-text-node hsx))) ;parser must be normalize
 185   (if (after-start-tag-p hsx)
 186       (setf (pending-text-node hsx) data)
 187       (unless (whitespacep data)
 188         ;; we already saw an element sibling, so discard whitespace
 189         (advance hsx
 190                  (mixed-text\' hsx (current-pattern hsx))
 191                  "text node not valid")))
 192   (setf (after-start-tag-p hsx) nil))
 193
 194 (defmethod sax:start-element ((hsx validator) uri lname qname attributes)
 195   (declare (ignore qname))
 196   (when (pending-text-node hsx)
 197     ;; text node was the previous child, and we're in element content.
 198     ;; process non-whitespace now; discard whitespace completely
 199     (let ((data (pending-text-node hsx)))
 200       (unless (whitespacep data)
 201         (advance hsx
 202                  (mixed-text\' hsx (current-pattern hsx))
 203                  "text node")))
 204     (setf (pending-text-node hsx) nil))
 205   (setf attributes
 206         (remove-if (cxml::compose #'cxml::xmlns-attr-p #'sax:attribute-qname)
 207                    attributes))
 208   (let* ((p0 (current-pattern hsx))
 209          (p1 (open-start-tag\' hsx p0 uri lname))
 210          (p2 (progn
 211                (advance hsx p1 "element ~A (~A) not valid" lname uri)
 212                (attributes\' hsx p1 attributes)))
 213          (p3 (progn
 214                (advance hsx p2 "attributes not valid")
 215                (close-start-tag\' hsx p2))))
 216     (advance hsx p3 "attributes not valid")
 217     (setf (after-start-tag-p hsx) t)))
 218
 219 (defmethod sax:end-element ((hsx validator) uri lname qname)
 220   (declare (ignore uri lname qname))
 221   (when (after-start-tag-p hsx)
 222     ;; nothing at all?  pretend we saw whitespace.
 223     (sax:characters hsx ""))
 224   (when (pending-text-node hsx)
 225     ;; text node was the only child?
 226     ;; process it and handle whitespace specially
 227     (let* ((current (current-pattern hsx))
 228            (data (pending-text-node hsx))
 229            (next (text-only\' hsx current data)))
 230       (advance hsx
 231                (if (whitespacep data)
 232                    (intern-choice hsx current next)
 233                    next)
 234                "text node not valid"))
 235     (setf (pending-text-node hsx) nil))
 236   (advance hsx
 237            (end-tag\' hsx (current-pattern hsx))
 238            "end of element not valid"))
 239
 240 (defun eat (ok)
 241   (if ok *empty* *not-allowed*))
 242
 243
 244 ;;;; TEXT-ONLY' / NON-ELEMENT'
 245
 246 (defun text-only\' (handler pattern data)
 247   (data\' handler
 248           (non-element\' handler pattern)
 249           data))
 250
 251 (defgeneric non-element\' (handler pattern))
 252
 253 (defmethod non-element\' :around (hsx (pattern pattern))
 254   (ensuref pattern (non-element\'-cache hsx) (call-next-method)))
 255
 256 (defmethod non-element\' (hsx (pattern choice))
 257   (intern-choice hsx
 258                  (non-element\' hsx (pattern-a pattern))
 259                  (non-element\' hsx (pattern-b pattern))))
 260
 261 (defmethod non-element\' (hsx (pattern interleave))
 262   (let ((a (pattern-a pattern))
 263         (b (pattern-b pattern)))
 264     (intern-choice hsx
 265                    (intern-interleave hsx (non-element\' hsx a) b)
 266                    (intern-interleave hsx a (non-element\' hsx b)))))
 267
 268 (defmethod non-element\' (hsx (pattern group))
 269   (let* ((a (pattern-a pattern))
 270          (b (pattern-b pattern))
 271          (p (intern-group hsx (non-element\' hsx a) b)))
 272     (if (nullable a)
 273         (intern-choice hsx p (non-element\' hsx b))
 274         p)))
 275
 276 (defmethod non-element\' (hsx (pattern after))
 277   (intern-after hsx
 278                 (non-element\' hsx (pattern-a pattern))
 279                 (pattern-b pattern)))
 280
 281 (defmethod non-element\' (hsx (pattern one-or-more))
 282   (let ((child (pattern-child pattern)))
 283     (intern-group hsx
 284                   (non-element\' hsx child)
 285                   (intern-zero-or-more hsx child))))
 286
 287 (defmethod non-element\' (hsx (pattern element))
 288   *not-allowed*)
 289
 290 (defmethod non-element\' (hsx pattern)
 291   pattern)
 292
 293
 294 ;;;; DATA'
 295
 296 (defgeneric data\' (handler pattern data))
 297
 298 (defmethod data\' (hsx (pattern choice) data)
 299   (intern-choice hsx
 300                  (data\' hsx (pattern-a pattern) data)
 301                  (data\' hsx (pattern-b pattern) data)))
 302
 303 (defmethod data\' (hsx (pattern interleave) data)
 304   (let ((a (pattern-a pattern))
 305         (b (pattern-b pattern)))
 306     (intern-choice hsx
 307                    (intern-interleave hsx (data\' hsx a data) b)
 308                    (intern-interleave hsx a (data\' hsx b data)))))
 309
 310 (defmethod data\' (hsx (pattern group) data)
 311   (let* ((a (pattern-a pattern))
 312          (b (pattern-b pattern))
 313          (p (intern-group hsx (data\' hsx a data) b)))
 314     (if (nullable a)
 315         (intern-choice hsx p (data\' hsx b data))
 316         p)))
 317
 318 (defmethod data\' (hsx (pattern after) data)
 319   (intern-after hsx
 320                 (data\' hsx (pattern-a pattern) data)
 321                 (pattern-b pattern)))
 322
 323 (defmethod data\' (hsx (pattern one-or-more) data)
 324   (let ((child (pattern-child pattern)))
 325     (intern-group hsx
 326                   (data\' hsx child data)
 327                   (intern-zero-or-more hsx child))))
 328
 329 (defmethod data\' (hsx (pattern text) data)
 330   (declare (ignore data))
 331   pattern)
 332
 333 (defmethod data\' (hsx (pattern value) data)
 334   (let ((data-type (pattern-type pattern)))
 335     (eat (cxml-types:equal-using-type
 336           data-type
 337           (pattern-value pattern)
 338           (cxml-types:parse data-type data hsx)))))
 339
 340 (defmethod data\' (hsx (pattern data) data)
 341   (eat (and (cxml-types:validp (pattern-type pattern) data hsx)
 342             (let ((except (pattern-except pattern)))
 343               (not (and except (nullable (data\' hsx except data))))))))
 344
 345 (defmethod data\' (hsx (pattern list-pattern) data)
 346   (eat (nullable (list\' hsx (pattern-child pattern) (words data)))))
 347
 348 (defmethod data\' (hsx pattern data)
 349   (declare (ignore pattern data))
 350   *not-allowed*)
 351
 352 (defun list\' (hsx pattern words)
 353   (dolist (word words)
 354     (setf pattern (data\' hsx pattern word)))
 355   pattern)
 356
 357 (defun words (str)
 358   (cl-ppcre:split #.(format nil "[~A]+" *whitespace*)
 359                   (string-trim *whitespace* str)))
 360
 361
 362 ;;;; MIXED-TEXT'
 363
 364 (defgeneric mixed-text\' (handler pattern))
 365
 366 (defmethod mixed-text\' :around (hsx (pattern pattern))
 367   (ensuref pattern (mixed-text\'-cache hsx) (call-next-method)))
 368
 369 (defmethod mixed-text\' (hsx (pattern choice))
 370   (intern-choice hsx
 371                  (mixed-text\' hsx (pattern-a pattern))
 372                  (mixed-text\' hsx (pattern-b pattern))))
 373
 374 (defmethod mixed-text\' (hsx (pattern interleave))
 375   (let ((a (pattern-a pattern))
 376         (b (pattern-b pattern)))
 377     (intern-choice hsx
 378                    (intern-interleave hsx (mixed-text\' hsx a) b)
 379                    (intern-interleave hsx a (mixed-text\' hsx b)))))
 380
 381 (defmethod mixed-text\' (hsx (pattern group))
 382   (let* ((a (pattern-a pattern))
 383          (b (pattern-b pattern))
 384          (p (intern-group hsx (mixed-text\' hsx a) b)))
 385     (if (nullable a)
 386         (intern-choice hsx p (mixed-text\' hsx b))
 387         p)))
 388
 389 (defmethod mixed-text\' (hsx (pattern after))
 390   (intern-after hsx
 391                 (mixed-text\' hsx (pattern-a pattern))
 392                 (pattern-b pattern)))
 393
 394 (defmethod mixed-text\' (hsx (pattern one-or-more))
 395   (let ((child (pattern-child pattern)))
 396     (intern-group hsx
 397                   (mixed-text\' hsx child)
 398                   (intern-zero-or-more hsx child))))
 399
 400 (defmethod mixed-text\' (hsx (pattern text))
 401   pattern)
 402
 403 (defmethod mixed-text\' (hsx pattern)
 404   (declare (ignore pattern))
 405   *not-allowed*)
 406
 407
 408 ;;;; INTERN
 409
 410 (defgeneric intern-choice (handler a b))
 411 (defmethod intern-choice (hsx a (b not-allowed)) a)
 412 (defmethod intern-choice (hsx (a not-allowed) b) b)
 413 (defmethod intern-choice (hsx a b)
 414   (ensuref (list 'choice a b)
 415            (registratur hsx)
 416            (let ((table (make-hash-table)))
 417              (labels ((record (p)
 418                         (cond
 419                           ((typep p 'choice)
 420                            (record (pattern-a p))
 421                            (record (pattern-b p)))
 422                           (t
 423                            (setf (gethash p table) t)))))
 424                (record a))
 425              (labels ((eliminate (p)
 426                         (cond
 427                           ((typep p 'choice)
 428                            (intern-choice hsx
 429                                           (eliminate (pattern-a p))
 430                                           (eliminate (pattern-b p))))
 431                           ((gethash p table)
 432                            *not-allowed*)
 433                           (t
 434                            p))))
 435                (let ((x (eliminate b)))
 436                  (if (typep x 'not-allowed)
 437                      a
 438                      (finalize-pattern (make-choice a x))))))))
 439
 440 (defgeneric intern-group (handler a b))
 441 (defmethod intern-group (hsx (a pattern) (b not-allowed)) b)
 442 (defmethod intern-group (hsx (a not-allowed) (b pattern)) a)
 443 (defmethod intern-group (hsx a (b empty)) a)
 444 (defmethod intern-group (hsx (a empty) b) b)
 445 (defmethod intern-group (hsx a b)
 446   (ensuref (list 'group a b)
 447            (registratur hsx)
 448            (finalize-pattern (make-group a b))))
 449
 450 (defgeneric intern-interleave (handler a b))
 451 (defmethod intern-interleave (hsx (a pattern) (b not-allowed)) b)
 452 (defmethod intern-interleave (hsx (a not-allowed) (b pattern)) a)
 453 (defmethod intern-interleave (hsx a (b empty)) a)
 454 (defmethod intern-interleave (hsx (a empty) b) b)
 455 (defmethod intern-interleave (hsx a b)
 456   (ensuref (list 'interleave a b)
 457            (registratur hsx)
 458            (finalize-pattern (make-interleave a b))))
 459
 460 (defgeneric intern-after (handler a b))
 461 (defmethod intern-after (hsx (a pattern) (b not-allowed)) b)
 462 (defmethod intern-after (hsx (a not-allowed) (b pattern)) a)
 463 (defmethod intern-after (hsx a b)
 464   (ensuref (list 'after a b)
 465            (registratur hsx)
 466            (finalize-pattern (make-after a b))))
 467
 468 (defgeneric intern-one-or-more (handler c))
 469 (defmethod intern-one-or-more (hsx (c not-allowed)) c)
 470 (defmethod intern-one-or-more (hsx c)
 471   (ensuref (list 'one-or-more c)
 472            (registratur hsx)
 473            (finalize-pattern (make-one-or-more c))))
 474
 475
 476 ;;;; ENSURE-REGISTRATUR
 477
 478 (defvar *seen-elements*)
 479
 480 (defun ensure-registratur (grammar)
 481   (or (schema-registratur grammar)
 482       (setf (schema-registratur grammar)
 483             (let ((table (make-hash-table :test 'equal))
 484                   (*seen-elements* '())
 485                   (done-elements '()))
 486               (setf (schema-interned-start grammar)
 487                     (intern-pattern (schema-start grammar) table))
 488               (loop
 489                  for elements = *seen-elements*
 490                  while elements do
 491                    (setf *seen-elements* nil)
 492                    (dolist (pattern elements)
 493                      (unless (find pattern done-elements)
 494                        (push pattern done-elements)
 495                        (setf (pattern-child pattern)
 496                              (intern-pattern (pattern-child pattern) table)))))
 497               table))))
 498
 499 ;;; FIXME: misnamed.  we don't really intern the originals pattern yet.
 500
 501 (defgeneric intern-pattern (pattern table))
 502
 503 (defmethod intern-pattern ((pattern element) table)
 504   (let ((copy (ensuref (list 'element pattern)
 505                        table
 506                        (copy-structure pattern))))
 507     (pushnew copy *seen-elements*)
 508     copy))
 509
 510 (defmethod intern-pattern :around ((pattern pattern) table)
 511   (finalize-pattern (call-next-method)))
 512
 513 (defmethod intern-pattern ((pattern %parent) table)
 514   (let ((c (intern-pattern (pattern-child pattern) table)))
 515     (if (eq c (pattern-child pattern))
 516         pattern
 517         (let ((copy (copy-structure pattern)))
 518           (setf (pattern-child copy) c)
 519           copy))))
 520
 521 (defmethod intern-pattern ((pattern %combination) table)
 522   (let ((a (intern-pattern (pattern-a pattern) table))
 523         (b (intern-pattern (pattern-b pattern) table)))
 524     (if (and (eq a (pattern-a pattern)) (eq b (pattern-b pattern)))
 525         pattern
 526         (let ((copy (copy-structure pattern)))
 527           (setf (pattern-a copy) a)
 528           (setf (pattern-b copy) b)
 529           copy))))
 530
 531 (defmethod intern-pattern ((pattern data) table)
 532   (let ((e (when (pattern-except pattern)
 533              (intern-pattern (pattern-except pattern) table))))
 534     (if (eq e (pattern-except pattern))
 535         pattern
 536         (let ((copy (copy-structure pattern)))
 537           (setf (pattern-except copy) e)
 538           copy))))
 539
 540 (defmethod intern-pattern ((pattern ref) table)
 541   (intern-pattern (defn-child (pattern-target pattern)) table))
 542
 543 (defmethod intern-pattern ((pattern empty) table)
 544   *empty*)
 545
 546 (defmethod intern-pattern ((pattern not-allowed) table)
 547   *not-allowed*)
 548
 549 (defmethod intern-pattern ((pattern %leaf) table)
 550   pattern)
 551
 552
 553 ;;;; APPLY-AFTER
 554
 555 (defgeneric apply-after (handler fn pattern))
 556
 557 (defmethod apply-after (hsx fn (pattern after))
 558   (intern-after hsx
 559                 (pattern-a pattern)
 560                 (funcall fn (pattern-b pattern))))
 561
 562 (defmethod apply-after (hsx fn (pattern choice))
 563   (intern-choice hsx
 564                  (apply-after hsx fn (pattern-a pattern))
 565                  (apply-after hsx fn (pattern-b pattern))))
 566
 567 (defmethod apply-after (hsx fn (pattern not-allowed))
 568   (declare (ignore hsx fn))
 569   pattern)
 570
 571
 572 ;;;; OPEN-START-TAG'
 573
 574 (defgeneric open-start-tag\' (handler pattern uri lname))
 575
 576 (defmethod open-start-tag\' :around (hsx (pattern pattern) uri lname)
 577   (ensuref (list pattern uri lname)
 578            (open-start-tag\'-cache hsx)
 579            (call-next-method)))
 580
 581 (defmethod open-start-tag\' (hsx (pattern choice) uri lname)
 582   (intern-choice hsx
 583                  (open-start-tag\' hsx (pattern-a pattern) uri lname)
 584                  (open-start-tag\' hsx (pattern-b pattern) uri lname)))
 585
 586 (defmethod open-start-tag\' (hsx (pattern element) uri lname)
 587   (if (contains (pattern-name pattern) (or uri "") lname)
 588       (intern-after hsx (pattern-child pattern) *empty*)
 589       *not-allowed*))
 590
 591 (defmethod open-start-tag\' (hsx (pattern interleave) uri lname)
 592   (intern-choice hsx
 593                  (apply-after
 594                   hsx
 595                   (lambda (p) (intern-interleave hsx p (pattern-b pattern)))
 596                   (open-start-tag\' hsx (pattern-a pattern) uri lname))
 597                  (apply-after
 598                   hsx
 599                   (lambda (p) (intern-interleave hsx (pattern-a pattern) p))
 600                   (open-start-tag\' hsx (pattern-b pattern) uri lname))))
 601
 602 (defun intern-zero-or-more (hsx c)
 603   (intern-choice hsx (intern-one-or-more hsx c) *empty*))
 604
 605 (defmethod open-start-tag\' (hsx (pattern one-or-more) uri lname)
 606   (let ((c (intern-zero-or-more hsx (pattern-child pattern))))
 607     (apply-after hsx
 608                  (lambda (p) (intern-group hsx p c))
 609                  (open-start-tag\' hsx (pattern-child pattern) uri lname))))
 610
 611 (defmethod open-start-tag\' (hsx (pattern group) uri lname)
 612   (let ((x (apply-after hsx
 613                         (lambda (p)
 614                           (intern-group hsx p (pattern-b pattern)))
 615                         (open-start-tag\' hsx (pattern-a pattern) uri lname))))
 616     (if (nullable (pattern-a pattern))
 617         (intern-choice hsx
 618                        x
 619                        (open-start-tag\' hsx (pattern-b pattern) uri lname))
 620         x)))
 621
 622 (defmethod open-start-tag\' (hsx (pattern after) uri lname)
 623   (apply-after hsx
 624                (lambda (p)
 625                  (intern-after hsx p (pattern-b pattern)))
 626                (open-start-tag\' hsx (pattern-a pattern) uri lname)))
 627
 628 (defmethod open-start-tag\' (hsx pattern uri lname)
 629   (declare (ignore hsx pattern uri lname))
 630   *not-allowed*)
 631
 632
 633 ;;;; ATTRIBUTES'
 634
 635 (defun attributes\' (handler pattern attributes)
 636   (dolist (a attributes)
 637     (setf pattern (attribute\' handler pattern a)))
 638   pattern)
 639
 640 (defgeneric attribute\' (handler pattern attribute))
 641
 642 (defmethod attribute\' (hsx (pattern after) a)
 643   (intern-after hsx
 644                 (attribute\' hsx (pattern-a pattern) a)
 645                 (pattern-b pattern)))
 646
 647 (defmethod attribute\' (hsx (pattern choice) a)
 648   (intern-choice hsx
 649                  (attribute\' hsx (pattern-a pattern) a)
 650                  (attribute\' hsx (pattern-b pattern) a)))
 651
 652 (defmethod attribute\' (hsx (pattern group) a)
 653   (intern-choice hsx
 654                  (intern-group hsx
 655                                (attribute\' hsx (pattern-a pattern) a)
 656                                (pattern-b pattern))
 657                  (intern-group hsx
 658                                (pattern-a pattern)
 659                                (attribute\' hsx (pattern-b pattern) a))))
 660
 661 (defmethod attribute\' (hsx (pattern interleave) a)
 662   (intern-choice hsx
 663                  (intern-interleave hsx
 664                                     (attribute\' hsx (pattern-a pattern) a)
 665                                     (pattern-b pattern))
 666                  (intern-interleave hsx
 667                                     (pattern-a pattern)
 668                                     (attribute\' hsx (pattern-b pattern) a))))
 669
 670 (defmethod attribute\' (hsx (pattern one-or-more) a)
 671   (intern-group hsx
 672                 (attribute\' hsx (pattern-child pattern) a)
 673                 (intern-zero-or-more hsx (pattern-child pattern))))
 674
 675 (defmethod attribute\' (hsx (pattern attribute) a)
 676   (eat (and (contains (pattern-name pattern)
 677                       (or (sax:attribute-namespace-uri a) "")
 678                       (sax:attribute-local-name a))
 679             (value-matches-p hsx
 680                              (pattern-child pattern)
 681                              (sax:attribute-value a)))))
 682
 683 (defun value-matches-p (hsx pattern value)
 684   (or (and (nullable pattern) (whitespacep value))
 685       (nullable (text-only\' hsx pattern value))))
 686
 687 (defun whitespacep (str)
 688   (zerop (length (string-trim *whitespace* str))))
 689
 690 (defmethod attribute\' (hsx pattern a)
 691   (declare (ignore hsx pattern a))
 692   *not-allowed*)
 693
 694
 695 ;;;; CLOSE-START-TAG'
 696
 697 (defgeneric close-start-tag\' (handler pattern))
 698
 699 (defmethod close-start-tag\' :around (hsx (pattern pattern))
 700   (ensuref pattern (close-start-tag\'-cache hsx) (call-next-method)))
 701
 702 (defmethod close-start-tag\' (hsx (pattern after))
 703   (intern-after hsx
 704                 (close-start-tag\' hsx (pattern-a pattern))
 705                 (pattern-b pattern)))
 706
 707 (defmethod close-start-tag\' (hsx (pattern choice))
 708   (intern-choice hsx
 709                 (close-start-tag\' hsx (pattern-a pattern))
 710                 (close-start-tag\' hsx (pattern-b pattern))))
 711
 712 (defmethod close-start-tag\' (hsx (pattern group))
 713   (intern-group hsx
 714                 (close-start-tag\' hsx (pattern-a pattern))
 715                 (close-start-tag\' hsx (pattern-b pattern))))
 716
 717 (defmethod close-start-tag\' (hsx (pattern interleave))
 718   (intern-interleave hsx
 719                      (close-start-tag\' hsx (pattern-a pattern))
 720                      (close-start-tag\' hsx (pattern-b pattern))))
 721
 722 (defmethod close-start-tag\' (hsx (pattern one-or-more))
 723   (intern-one-or-more hsx (close-start-tag\' hsx (pattern-child pattern))))
 724
 725 (defmethod close-start-tag\' (hsx (pattern attribute))
 726   (declare (ignore hsx))
 727   *not-allowed*)
 728
 729 (defmethod close-start-tag\' (hsx pattern)
 730   (declare (ignore hsx))
 731   pattern)
 732
 733
 734 ;;;; END-TAG\'
 735
 736 (defgeneric end-tag\' (handler pattern))
 737
 738 (defmethod end-tag\' :around (hsx (pattern pattern))
 739   (ensuref pattern (end-tag\'-cache hsx) (call-next-method)))
 740
 741 (defmethod end-tag\' (hsx (pattern choice))
 742   (intern-choice hsx
 743                  (end-tag\' hsx (pattern-a pattern))
 744                  (end-tag\' hsx (pattern-b pattern))))
 745
 746 (defmethod end-tag\' (hsx (pattern after))
 747   (if (nullable (pattern-a pattern))
 748       (pattern-b pattern)
 749       *not-allowed*))
 750
 751 (defmethod end-tag\' (hsx pattern)
 752   (declare (ignore hsx pattern))
 753   *not-allowed*)
 754
 755
 756 ;;;; TEXT NORMALIZER
 757
 758 ;;; FIXME: cxml should do that
 759
 760 ;;; FIXME: since we ignore PI, CDATA, and comment events, we should probably
 761 ;;; discard them properly.
 762
 763 (defclass text-normalizer (cxml:sax-proxy sax:sax-parser-mixin)
 764   ((pending-text-node :initform (make-string-output-stream)
 765                       :accessor pending-text-node)))
 766
 767 (defmethod sax:characters ((handler text-normalizer) data)
 768   (write-string data (pending-text-node handler)))
 769
 770 (defun flush-pending (handler)
 771   (let ((str (get-output-stream-string (pending-text-node handler))))
 772     (unless (zerop (length str))
 773       (sax:characters (cxml:proxy-chained-handler handler) str))))
 774
 775 (defmethod sax:start-element :before
 776     ((handler text-normalizer) uri lname qname attributes)
 777   (declare (ignore uri lname qname attributes))
 778   (flush-pending handler))
 779
 780 (defmethod sax:end-element :before
 781     ((handler text-normalizer) uri lname qname)
 782   (declare (ignore uri lname qname))
 783   (flush-pending handler))
 784
 785
 786 ;;;; EXPECTATION, DESCRIBE-NAME
 787
 788 (defgeneric expectation (pattern stream))
 789 (defgeneric describe-name (name-class stream))
 790
 791 (defmethod expectation ((pattern after) s)
 792   (expectation (pattern-a pattern) s))
 793
 794 (defmethod expectation ((pattern group) s)
 795   (expectation (pattern-a pattern) s))
 796
 797 (defmethod expectation ((pattern attribute) s)
 798   (pprint-logical-block (s nil)
 799     (write-string "an attribute " s)
 800     (describe-name (pattern-name pattern) s)
 801     (format s "~:@_with a value of ")
 802     (expectation (pattern-child pattern) s)))
 803
 804 (defmethod expectation ((pattern choice) s)
 805   (pprint-logical-block (s nil)
 806     (expectation (pattern-a pattern) s)
 807     (format s "~:@_or ")
 808     (expectation (pattern-b pattern) s)))
 809
 810 (defmethod expectation ((pattern element) s)
 811   (pprint-logical-block (s nil)
 812     (write-string "an element " s)
 813     (describe-name (pattern-name pattern) s)))
 814
 815 (defmethod expectation ((pattern data) s)
 816   (format s "a text node of type ~A" (pattern-type pattern)))
 817
 818 (defmethod expectation ((pattern interleave) s)
 819   (pprint-logical-block (s nil)
 820     (expectation (pattern-a pattern) s)
 821     (format s "~:@_interleaved with ")
 822     (expectation (pattern-b pattern) s)))
 823
 824 (defmethod expectation ((pattern list-pattern) s)
 825   (pprint-logical-block (s nil)
 826     (format s "a whitespace separated list of:~:@_")
 827     (expectation (pattern-child pattern) s)))
 828
 829 (defmethod expectation ((pattern not-allowed) s)
 830   (write-string "nothing" s))
 831
 832 (defmethod expectation ((pattern one-or-more) s)
 833   (pprint-logical-block (s nil)
 834     (format s "one or more of:~:@_")
 835     (expectation (pattern-child pattern) s)))
 836
 837 (defmethod expectation ((pattern text) s)
 838   (write-string "whitespace" s))
 839
 840 (defmethod expectation ((pattern value) s)
 841   (format s "a text node of type ~A and value ~S"
 842           (pattern-type pattern)
 843           (pattern-value pattern)))
 844
 845 (defmethod expectation ((pattern empty) s)
 846   (write-string "nothing more" s))
 847
 848 (defmethod describe-name ((nc name) s)
 849   (format s "named ~S, in the namespace ~S"
 850           (name-lname nc)
 851           (name-uri nc)))
 852
 853 (defmethod describe-name ((nc any-name) s)
 854   (pprint-logical-block (s nil)
 855     (write-string "of any name" s)
 856     (when (any-name-except nc)
 857       (format s "~:@_except ")
 858       (describe-name (any-name-except nc) s))))
 859
 860 (defmethod describe-name ((nc ns-name) s)
 861   (pprint-logical-block (s nil)
 862     (format s "with a name in the namespace ~S" (ns-name-uri nc))
 863     (when (ns-name-except nc)
 864       (format s "~:@_except for ")
 865       (describe-name (ns-name-except nc) s))))
 866
 867 (defmethod describe-name ((nc name-class-choice) s)
 868   (pprint-logical-block (s nil)
 869     (describe-name (name-class-choice-a nc) s)
 870     (format s "~:@_or ")
 871     (describe-name (name-class-choice-b nc) s)))
 872
 873
 874 ;;;;
 875
 876 (finalize-pattern *empty*)
 877 (finalize-pattern *not-allowed*)