node.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16 ;;;
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package :cxml-stp-impl)
  30
  31 #+sbcl
  32 (declaim (optimize (debug 2)))
  33
  34 (defvar *check-uri-syntax* nil
  35   "If true (the default), a warning is issued if a string specified
  36    as a namespace URI does not have URI syntax.")
  37 (defun check-namespace-uri (uri)
  38   (when (and *check-uri-syntax*
  39              (not (or (search "://" uri)
  40                       (eql 4 (mismatch "uri:" uri))
  41                       (eql 4 (mismatch "urn:" uri)))))
  42     (warn "namespace URI does not look like an absolute URL: ~S" uri)))
  43
  44 (define-condition stp-error (simple-error)
  45   ()
  46   (:documentation "The class of all STP errors."))
  47
  48 (defun stp-error (fmt &rest args)
  49   "@unexport{}"
  50   (error 'stp-error :format-control fmt :format-arguments args))
  51
  52
  53 ;;;; Class NODE
  54
  55 (defgeneric string-value (node)
  56   (:documentation
  57    "@arg[node]{an instance of @class{node}}
  58     @return{a string}
  59     @short{Returns the string value of @code{node} as defined by XPath.}
  60
  61     For a document, this is the value of its root element.
  62
  63     For an element, the concatenation of the values of those child nodes
  64     is returned that are elements or text nodes.
  65     (Leaving only the PCDATA content.)
  66
  67     For a text, comment, and processing instruction nodes, the node's data
  68     is returned.
  69
  70     For an attribute, the attribute value is returned.
  71
  72     The value for document types is not specified."))
  73
  74 (defgeneric parent (node)
  75   (:documentation
  76    "@arg[node]{an @class{node}}
  77     @return{the parent node, or nil}
  78     @short{Returns the node's parent.}"))
  79
  80 (defgeneric base-uri (node)
  81   (:documentation
  82    "@arg[node]{an @class{node}}
  83     @return{a string}
  84     @short{Returns the node's base URI.}"))
  85
  86 (defun cxml-stp:document (node)
  87   "@arg[node]{an instance of @class{node}}
  88    @return{a @class{document} or nil}
  89    @short{Returns the document node ancestor of @code{node}.}
  90
  91    Returns the @class{document} node that is the @fun{root} of @code{node}
  92    or @code{nil} if the root node is not a document."
  93   (check-type node node)
  94   (loop
  95      for parent = node then (parent parent)
  96      while (and parent (not (typep parent 'cxml-stp:document)))
  97      finally (return parent)))
  98
  99 (defun root (node)
 100   "@arg[node]{an instance of @class{node}}
 101    @return{a @class{node} or nil}
 102    @short{Returns the root of the tree of nodes @code{node} is part of.}
 103
 104    In a complete document, this is an instance of @class{document}, but
 105    a detached subtree can have any node as its root.  In particular, the
 106    argument itself is returned if it does not have a @fun{parent}."
 107   (check-type node node)
 108   (loop
 109      for p = (parent node) then (parent p)
 110      and q = node then p
 111      while p
 112      finally (return q)))
 113
 114 ;; (defgeneric base-uri (node)) ;fixme: hier muessen wir wissen, ob specified
 115 ;; (defmethod base-uri ((node node))
 116 ;;   (let ((parent (parent node)))
 117 ;;     (if parent
 118 ;;         (base-uri parent)
 119 ;;         "")))
 120
 121 (defgeneric detach (node)
 122   (:documentation
 123    "@arg[node]{a @class{node}}
 124     @short{This function removes a child node or attribute.}
 125
 126     In contrast to functions for child nodes, this function can also remove
 127     an attribute from its parent.
 128
 129     @see{parent}"))
 130 (defmethod detach ((node node))
 131   (when (parent node)
 132     (delete-child node (parent node))))
 133
 134 (defgeneric copy (node)
 135   (:documentation
 136    "@arg[node]{a @class{node}}
 137     @short{This function copies a node recursively.}
 138
 139     The resulting node is of the same class as the argument, and all
 140     child nodes and attributes are copied in the same way.
 141
 142     Shared structure includes only primitive slot values like strings.
 143     (The consequences are undefined if user code mutates such values, whether
 144     @code{copy} is used or not.)"))
 145
 146 (defgeneric serialize (node handler)
 147   (:documentation
 148    "@arg[node]{a @class{node}}
 149     @short{This function generates SAX events representing @code{node}.}
 150
 151     Use this function together with a serialization sink to generate
 152     a serialized XML document.
 153
 154     Examples. Serializing to a stream:
 155     @begin{pre}CL-USER> (stp:serialize (stp:make-document (stp:make-element \"test\"))
 156                         (cxml:make-character-stream-sink *standard-output*))
 157 <?xml version=\"1.0\" encoding=\"UTF-8\"?>
 158 <test/>
 159 #<SWANK-BACKEND::SLIME-OUTPUT-STREAM {10037EA611@}>
 160 @end{pre}
 161     Examples. Serializing to a string:
 162     @begin{pre}CL-USER> (stp:serialize (stp:make-document (stp:make-element \"test\"))
 163                         (cxml:make-string-sink))
 164 \"<?xml version=\\\"1.0\\\" encoding=\\\"UTF-8\\\"?>
 165 <test/>\"
 166 @end{pre}
 167
 168    @see{make-builder}"))
 169
 170 ;;; CHILDREN-related convenience functions
 171
 172 (defgeneric map-children (result-type function node)
 173   (:documentation
 174    "@arg[result-type]{a sequence type specifier, or nil}
 175     @arg[function]{a designator for a function of one argument}
 176     @arg[node]{a @class{node}}
 177     @return{an sequence of @code{result-type}, or nil}
 178     @short{Applies @code{function} to successive child nodes.}
 179
 180     The @code{result-type} specifies the type of the resulting sequence.
 181     @code{map-children} returns nil if @code{result-type} is nil.  Otherwise
 182     it returns a sequence such that element i is the result of applying
 183     @code{function} to child i of @class{node}."))
 184
 185 (defmacro do-children ((var node &optional result) &body body)
 186   "@arg[var]{symbol, a variable name}
 187    @arg[node]{a @class{node}}
 188    @arg[result]{a form}
 189    @return{the result of evaluating @code{result}}
 190    Executes @code{body} with @code{var} bound to successive child
 191      nodes."
 192   `(block nil
 193      (map-children nil (lambda (,var) ,@body) ,node)
 194      (let (,var)
 195        (declare (ignorable ,var))
 196        ,result)))
 197
 198 (defun list-children (node)
 199   "@arg[node]{a @class{node}}
 200    @return{a list of nodes}
 201    Returns a freshly consed list containing the child nodes of @code{node}."
 202   (map-children 'list #'identity node))
 203
 204 (defun nth-child (n parent)
 205   "@arg[n]{a non-negative integer}
 206    @arg[parent]{a @class{node}}
 207    @return{a @class{node}}
 208    @short{Returns child node @code{n} of @code{parent}}, or signals an error
 209    if n is negative or as large or larger that the number of child nodes."
 210   (elt (%children parent) n))
 211
 212 (defun first-child (node)
 213   "@arg[node]{a @class{node}}
 214    @return{a @class{node} or nil}
 215    Returns first child of @code{node}, or nil."
 216   (let ((c (%children node)))      ;VECTOR or NIL, but not arbitrary list
 217     (when (plusp (length c))
 218       (elt c 0))))
 219
 220 (defun last-child (node)
 221   "@arg[node]{a @class{node}}
 222    @return{a @class{node} or nil}
 223    Returns last child of @code{node}, or nil."
 224   (let* ((c (%children node))      ;VECTOR or NIL, but not arbitrary list
 225          (l (length c)))
 226     (when (plusp l)
 227       (elt c (1- l)))))
 228
 229 (defun previous-sibling (node)
 230   "@arg[node]{a @class{node}}
 231    @return{a @class{node} or nil}
 232    @short{Returns the child preceding @code{node} in the child list of its
 233      parent.}
 234
 235    Signals an error if @code{node} has no parent or is the first child of its
 236    parent."
 237   (let ((p (parent node)))
 238     (unless p
 239       (stp-error "node has no parent"))
 240     (let ((idx (1- (child-position node p))))
 241       (when (minusp idx)
 242         (stp-error "node has no previous sibling"))
 243       (nth-child idx p))))
 244
 245 (defun next-sibling (node)
 246   "@arg[node]{a @class{node}}
 247    @return{a @class{node} or nil}
 248    @short{Returns the child following @code{node} in the child list of its
 249      parent.}
 250
 251    Signals an error if @code{node} has no parent or is the last child of its
 252    parent."
 253   (let ((p (parent node)))
 254     (unless p
 255       (stp-error "node has no parent"))
 256     (let ((idx (1+ (child-position node p)))
 257           (c (%children p)))
 258       (when (eql idx (length c))
 259         (stp-error "node has no next sibling"))
 260       (nth-child idx p))))
 261
 262 (defun number-of-children (parent)
 263   "@arg[parent]{a @class{node}}
 264    @return{the number of child nodes}
 265    Returns the number of {parent}'s child nodes.
 266    @see{count-children}"
 267   (length (%children parent)))
 268
 269 (defun count-children
 270     (value parent &rest args &key from-end (start 0) end key test)
 271   "@arg[value]{an object}
 272    @arg[parent]{a @class{node}}
 273    @arg[from-end]{a generalized boolead}
 274    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 275    @arg[key]{a designator for a function of one argument, or nil}
 276    @arg[test]{a designator for a function of two arguments, or nil}
 277    @return{a non-negative integer less than or equal to the number of
 278      child nodes}
 279    Counts (and returns the number of) @code{parent}'s child nodes satisfying
 280    the test.
 281    @see{number-of-children}
 282    @see{count-children-if}"
 283   (declare (ignore from-end start end key test))
 284   (apply #'count value (%children parent) args))
 285
 286 (defun count-children-if
 287     (predicate parent &rest args &key from-end (start 0) end key)
 288   "@arg[predicate]{a designator for a function of one argument that returns
 289      a generalized boolean}
 290    @arg[parent]{a @class{node}}
 291    @arg[from-end]{a generalized boolead}
 292    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 293    @arg[key]{a designator for a function of one argument, or nil}
 294    @return{a non-negative integer less than or equal to the number of
 295      child nodes}
 296    Counts (and returns the number of) @code{parent}'s child nodes satisfying
 297    @code{predicate}.
 298    @see{number-of-children}
 299    @see{count-children}"
 300   (declare (ignore from-end start end key))
 301   (apply #'count-if predicate (%children parent) args))
 302
 303 (defun find-child
 304     (value parent &rest args &key from-end (start 0) end key test)
 305   "@arg[value]{an object}
 306    @arg[parent]{a @class{node}}
 307    @arg[from-end]{a generalized boolead}
 308    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 309    @arg[key]{a designator for a function of one argument, or nil}
 310    @arg[test]{a designator for a function of two arguments, or nil}
 311    @return{a @class{node} or nil}
 312    Searches for a child node of @code{parent} that satisfies the @code{test}
 313    and returns it.
 314
 315    @see{find-child-if}"
 316   (declare (ignore from-end start end key test))
 317   (apply #'find value (%children parent) args))
 318
 319 (defun find-child-if
 320     (predicate parent &rest args &key from-end (start 0) end key)
 321   "@arg[predicate]{a designator for a function of one argument that returns
 322      a generalized boolean}
 323    @arg[parent]{a @class{node}}
 324    @arg[from-end]{a generalized boolead}
 325    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 326    @arg[key]{a designator for a function of one argument, or nil}
 327    @return{a @class{node} or nil}
 328    Searches for a child node of @code{parent} that satisfies @code{predicate}
 329    and returns it.
 330
 331    @see{find-child}"
 332   (declare (ignore from-end start end key))
 333   (apply #'find-if predicate (%children parent) args))
 334
 335 (defun child-position
 336     (value parent &rest args &key from-end (start 0) end key test)
 337   "@arg[value]{an object}
 338    @arg[parent]{a @class{node}}
 339    @arg[from-end]{a generalized boolead}
 340    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 341    @arg[key]{a designator for a function of one argument, or nil}
 342    @arg[test]{a designator for a function of two arguments, or nil}
 343    @return{a @class{node} or nil}
 344    Searches for a child node of @code{parent} that satisfies the @code{test}
 345    and returns its position.
 346
 347    @see{child-position-if}"
 348   (declare (ignore from-end start end key test))
 349   (apply #'position value (%children parent) args))
 350
 351 (defun child-position-if
 352     (predicate parent &rest args &key from-end (start 0) end key)
 353   "@arg[predicate]{a designator for a function of one argument that returns
 354      a generalized boolean}
 355    @arg[parent]{a @class{node}}
 356    @arg[from-end]{a generalized boolead}
 357    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 358    @arg[key]{a designator for a function of one argument, or nil}
 359    @arg[test]{a designator for a function of two arguments, or nil}
 360    @return{a @class{node} or nil}
 361    Searches for a child node of @code{parent} that satisfies the @code{test}
 362    and returns its position.
 363
 364    @see{child-position}"
 365   (declare (ignore from-end start end key))
 366   (apply #'position-if predicate (%children parent) args))
 367
 368 (defun filter-children
 369     (predicate parent &rest args &key from-end (start 0) end count key)
 370   "@arg[predicate]{a designator for a function of one argument that returns
 371      a generalized boolean}
 372    @arg[parent]{a @class{node}}
 373    @arg[from-end]{a generalized boolead}
 374    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 375    @arg[key]{a designator for a function of one argument, or nil}
 376    @arg[test]{a designator for a function of two arguments, or nil}
 377    @arg[count]{an integer or nil}
 378    @return{a sequence containing nodes}
 379    @short{Return a list of child nodes of @code{parent} from which nodes that
 380      do not satisfy @code{predicate} have been removed.}
 381
 382    This function returns the same list as @code{remove-if-not} on the result
 383    of @fun{list-children}."
 384   (declare (ignore from-end start end count key))
 385   (apply #'remove-if-not predicate (list-children parent) args))
 386
 387 (defun map-recursively (fn node)
 388   "@arg[fn]{a designator for a function of one argument}
 389    @arg[node]{a @class{node}}
 390    @return{nil}
 391    Applies @code{fn} to successive descendants of @code{node} in
 392    pre-order."
 393   (funcall fn node)
 394   (map nil
 395        (lambda (c) (map-recursively fn c))
 396        (%children node)))
 397
 398 (defmacro do-recursively ((var node &optional result) &body body)
 399   "@arg[var]{symbol, a variable name}
 400    @arg[node]{a @class{node}}
 401    @arg[result]{a form}
 402    @return{the result of evaluating @code{result}}
 403    Executes @code{bode} with @code{var} bound to successive descendants of
 404    @code{node} in pre-order."
 405   `(block nil
 406      (map-recursively (lambda (,var) ,@body) ,node)
 407      (let (,var)
 408        (declare (ignorable ,var))
 409        ,result)))
 410
 411 (defun find-recursively (item node &key key test)
 412   "@arg[item]{an object}
 413    @arg[node]{a @class{node}}
 414    @arg[key]{a designator for a function of one argument, or nil}
 415    @arg[test]{a designator for a function of two arguments, or nil}
 416    @return{a @class{node} or nil}
 417    Searches in pre-order for the first descendant of @code{node} that
 418    satisfies the @code{test} and returns it.
 419
 420    @see{find-child-if}"
 421   (setf key (or key #'identity))
 422   (setf test (or test #'eql))
 423   (do-recursively (child node)
 424     (when (funcall test item (funcall key child))
 425       (return child))))
 426
 427 (defun find-recursively-if (predicate node &key key)
 428   "@arg[test]{a designator for a function of one argument that returns
 429      a generalized boolean}
 430    @arg[node]{a @class{node}}
 431    @arg[key]{a designator for a function of one argument, or nil}
 432    @return{a @class{node} or nil}
 433    Searches in pre-order for the first descendant of @code{node} that
 434    satisfies the @code{test} and returns it.
 435
 436    @see{find-child-if}"
 437   (setf key (or key #'identity))
 438   (do-recursively (child node)
 439     (when (funcall predicate (funcall key child))
 440       (return child))))
 441
 442 (defun filter-recursively (test node &key key)
 443   "@arg[test]{a designator for a function of one argument that returns
 444      a generalized boolean}
 445    @arg[node]{a @class{node}}
 446    @arg[key]{a designator for a function of one argument, or nil}
 447    @arg[test]{a designator for a function of two arguments, or nil}
 448    @return{a sequence containing nodes}
 449    Return a list of descendant nodes of @code{node} in pre-order, from which
 450    nodes that do not satisfy @code{predicate} have been removed."
 451   (setf key (or key #'identity))
 452   (setf test (or test #'eql))
 453   (let ((result '()))
 454     (do-recursively (child node)
 455       (when (funcall test (funcall key child))
 456         (push child result)))
 457     (nreverse result)))
 458
 459
 460 ;;; tbd
 461
 462 ;;; (defun query (node xpath)
 463 ;;;   ;; fixme
 464 ;;;   )
 465
 466
 467 ;;;; PRINT-OBJECT
 468
 469 (defgeneric slots-for-print-object (node)
 470   (:method-combination append))
 471
 472 (defun maybe-uri->string (thing)
 473   (if (puri:uri-p thing)
 474       (princ-to-string thing)
 475       (non-empty-string thing)))
 476
 477 (defmethod slots-for-print-object append ((node parent-node))
 478   '((:base-uri %base-uri maybe-uri->string)
 479     (:children list-children identity)))
 480
 481 (defmethod print-object ((object node) stream)
 482   (when (and *print-readably* (not *read-eval*))
 483     (error "cannot print STP nodes readably without *read-eval*"))
 484   ;; zzz pretty printing on clisp introduces spurious closing parens
 485   (if (and *print-pretty* #+clisp nil)
 486       (pretty-print-node object stream)
 487       (ugly-print-node object stream)))
 488
 489 (defun pretty-print-node (node stream)
 490   (let* ((slots (mapcan (lambda (spec)
 491                           (destructuring-bind (key fn &optional test) spec
 492                             (let ((value (funcall fn node)))
 493                               (when (or (null test) (funcall test value))
 494                                 (list (list key value))))))
 495                         (slots-for-print-object node)))
 496          (constructor
 497           (intern (symbol-name (class-name (class-of node))) :cxml-stp-impl))
 498          (level *print-level*)
 499          (length *print-length*)
 500          (*print-level* nil)
 501          (*print-length* nil))
 502     (pprint-logical-block (stream nil :prefix "#.(" :suffix ")")
 503       (write constructor :stream stream)
 504       (when (parent node)
 505         (write-char #\space stream)
 506         (pprint-newline :linear stream)
 507         (pprint-pop)
 508         (format stream "#| ~S of type ~A |#"
 509                 :parent
 510                 (type-of (parent node))))
 511       (let ((remaining-slots slots))
 512         (when remaining-slots
 513           (write-char #\space stream)
 514           (pprint-newline :linear stream)
 515           (loop
 516              (pprint-pop)
 517              (destructuring-bind (key value) (pop remaining-slots)
 518                (write key :stream stream)
 519                (write-char #\space stream)
 520                (pprint-newline :miser stream)
 521                (let ((*print-level* level)
 522                      (*print-length* length))
 523                  (unless (typep value '(or string null))
 524                    (write-char #\' stream))
 525                  (write value :stream stream))
 526                (when (null remaining-slots)
 527                  (return))
 528                (write-char #\space stream)
 529                (pprint-newline :linear stream))))))))
 530
 531 (defun ugly-print-node (node stream)
 532   (let* ((slots (mapcan (lambda (spec)
 533                           (destructuring-bind (key fn &optional test) spec
 534                             (let ((value (funcall fn node)))
 535                               (when (or (null test) (funcall test value))
 536                                 (list (list key value))))))
 537                         (slots-for-print-object node)))
 538          (constructor
 539           (intern (symbol-name (class-name (class-of node))) :cxml-stp-impl))
 540          (level *print-level*)
 541          (length *print-length*)
 542          (*print-level* nil)
 543          (*print-length* nil))
 544     (write-string "#.(" stream)
 545     (write constructor :stream stream)
 546     (let ((remaining-slots slots))
 547       (when remaining-slots
 548         (write-char #\space stream)
 549         (loop
 550            (destructuring-bind (key value) (pop remaining-slots)
 551              (write key :stream stream)
 552              (write-char #\space stream)
 553              (let ((*print-level* level)
 554                    (*print-length* length))
 555                (unless (typep value '(or string null))
 556                  (write-char #\' stream))
 557                (write value :stream stream))
 558              (when (null remaining-slots)
 559                (return))
 560              (write-char #\space stream)))))
 561     (write-string ")" stream)))
 562
 563 (defgeneric reconstruct (node &key &allow-other-keys)
 564   (:method-combination progn))
 565
 566 (defmacro defreader (name (&rest args) &body body)
 567   (let ((fn (intern (symbol-name name) :cxml-stp-impl)))
 568     `(progn
 569        (defun ,fn (&rest keys)
 570          "@unexport{}"
 571          (let ((result (make-instance ',name)))
 572            (apply #'reconstruct result keys)
 573            result))
 574        (defmethod reconstruct
 575            progn
 576            ((this ,name)
 577             &key ,@(loop
 578                       for arg in args
 579                       collect (if (symbolp arg)
 580                                   `(,arg (error "slot ~A missing in printed representation"
 581                                                 ',arg))
 582                                   arg))
 583             &allow-other-keys)
 584          ,@body))))