number.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; 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 (in-package :xuriella)
  31
  32 (define-instruction xsl:number (args env)
  33   (destructuring-bind (&key level count from value format lang letter-value
  34                             grouping-separator grouping-size)
  35       args
  36     (let ((count (and count (compile-pattern count env)))
  37           (from  (and from (compile-pattern from env)))
  38           (value (and value (compile-xpath value env)))
  39           (format       (compile-avt (or format "1") env))
  40           (lang         (compile-avt (or lang "") env))
  41           (letter-value (compile-avt (or letter-value "foo") env))
  42           (grouping-separator
  43            (and grouping-separator (compile-avt grouping-separator env)))
  44           (grouping-size (and grouping-size (compile-avt grouping-size env))))
  45       (lambda (ctx)
  46         (let ((value              (when value
  47                                     (round (xpath:number-value
  48                                             (funcall value ctx)))))
  49               (format             (funcall format ctx))
  50               (lang               (funcall lang ctx))
  51               (letter-value       (funcall letter-value ctx))
  52               (grouping-separator (when grouping-separator
  53                                     (funcall grouping-separator ctx)))
  54               (grouping-size      (when grouping-size
  55                                     (funcall grouping-size ctx))))
  56           (write-text
  57            (format-number-list
  58             (or value
  59                 (compute-number-list (or level "single")
  60                                      (xpath::context-node ctx)
  61                                      count
  62                                      from))
  63             format
  64             lang
  65             letter-value
  66             grouping-separator
  67             grouping-size)))))))
  68
  69 (defun compile-pattern (str env)
  70   (compile-xpath
  71    `(xpath:xpath
  72      (:path (:ancestor-or-self :node) ,@(cdr (parse-pattern str))))
  73    env))
  74
  75 (defun pattern-thunk-matches-p (pattern-thunk node)
  76   (find node
  77         (xpath:all-nodes (funcall pattern-thunk (xpath:make-context node)))))
  78
  79 (defun ancestors-using-count-and-from (node count from)
  80   (let ((ancestors
  81          (xpath::force
  82           (funcall (xpath::axis-function :ancestor-or-self) node))))
  83     (remove-if-not (lambda (ancestor)
  84                      (pattern-thunk-matches-p count ancestor))
  85                    (if from
  86                        (loop
  87                           for a in ancestors
  88                           when (pattern-thunk-matches-p from a)
  89                           do (return result)
  90                           collect a into result
  91                           finally (return nil))
  92                        ancestors))))
  93
  94 (defun node-position-among-siblings (node count)
  95   (1+
  96    (count-if (lambda (sibling)
  97                (pattern-thunk-matches-p count sibling))
  98              (xpath::force
  99               (funcall (xpath::axis-function :preceding-sibling) node)))))
 100
 101 (defun compute-number-list (level node count from)
 102   (unless count
 103     (setf count
 104           (let ((qname (xpath-protocol:qualified-name node)))
 105             (lambda (ctx)
 106               (let ((node (xpath:context-node ctx)))
 107                 (xpath:make-node-set
 108                  (if (equal (xpath-protocol:qualified-name node) qname)
 109                      (list node)
 110                      nil)))))))
 111   (cond
 112     ((equal level "single")
 113      (let ((ancestor (car (ancestors-using-count-and-from node count from))))
 114        (if ancestor
 115            (list (node-position-among-siblings ancestor count))
 116            nil)))
 117     ((equal level "multiple")
 118      (mapcar (lambda (ancestor)
 119                (node-position-among-siblings ancestor count))
 120              (reverse
 121               (ancestors-using-count-and-from node count from))))
 122     ((equal level "any")
 123      (destructuring-bind (root)
 124          (xpath::force (funcall (xpath::axis-function :root) node))
 125        (let ((nodes (xpath::force (funcall (xpath::axis-function :descendant-or-self) root))))
 126          (when from
 127            (loop
 128               for (current . rest) on nodes
 129               until (pattern-thunk-matches-p from current)
 130               finally (setf nodes rest)))
 131          (list
 132           (loop
 133              for node in nodes
 134              while (pattern-thunk-matches-p count node)
 135              count t)))))
 136     (t
 137      (xslt-error "invalid number level: ~A" level))))
 138
 139 (defun format-number-list
 140     (list format lang letter-value grouping-separator grouping-size)
 141   (declare (ignore lang letter-value))
 142   (if (equal format "1")
 143       (format nil "~{~D~^.~}" list)
 144       (error "sorry, format-number-list not implemented yet")))