number.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: 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 (defun xsl-number-value (y)
  33   (let ((x (xpath:number-value y)))
  34     (if (or (< x 0.5)
  35             (xpath::nan-p x)
  36             (xpath::inf-p x)
  37             (>= x (expt 2 31))          ;-(
  38             )
  39         (xpath:string-value x)
  40         (round (xpath::xnum-round x)))))
  41
  42 (define-instruction xsl:number (args env)
  43   (destructuring-bind (&key level count from value format lang letter-value
  44                             grouping-separator grouping-size)
  45       args
  46     (let ((count (and count (xpath:make-pattern-matcher* count env)))
  47           (from  (and from (xpath:make-pattern-matcher* from env)))
  48           (value (and value (compile-xpath value env)))
  49           (format       (compile-avt (or format "1") env))
  50           (lang         (compile-avt (or lang "") env))
  51           (letter-value (compile-avt (or letter-value "foo") env))
  52           (grouping-separator
  53            (and grouping-separator (compile-avt grouping-separator env)))
  54           (grouping-size (and grouping-size (compile-avt grouping-size env))))
  55       (lambda (ctx)
  56         (let ((value              (when value
  57                                     (xsl-number-value (funcall value ctx))))
  58               (format             (funcall format ctx))
  59               (lang               (funcall lang ctx))
  60               (letter-value       (funcall letter-value ctx))
  61               (grouping-separator (when grouping-separator
  62                                     (funcall grouping-separator ctx)))
  63               (grouping-size      (when grouping-size
  64                                     (xpath:number-value
  65                                      (funcall grouping-size ctx)))))
  66           (if (stringp value)
  67               (write-text value)
  68               (write-text
  69                (format-number-list
  70                 (if value
  71                     (list value)
  72                     (compute-number-list (or level "single")
  73                                          (xpath::context-node ctx)
  74                                          count
  75                                          from))
  76                 format
  77                 lang
  78                 letter-value
  79                 grouping-separator
  80                 grouping-size))))))))
  81
  82 (defun pattern-thunk-matches-p (pattern-thunk node)
  83   (xpath:matching-value pattern-thunk node))
  84
  85 (defun ancestors-using-count-and-from (node count from)
  86   (let ((ancestors
  87          (xpath::force
  88           (funcall (xpath::axis-function :ancestor-or-self) node))))
  89     (remove-if-not (lambda (ancestor)
  90                      (pattern-thunk-matches-p count ancestor))
  91                    (if from
  92                        (loop
  93                           for a in ancestors
  94                           when (pattern-thunk-matches-p from a)
  95                           do (return result)
  96                           collect a into result
  97                           finally (return ancestors))
  98                        ancestors))))
  99
 100 (defun node-position-among-siblings (node count)
 101   (1+
 102    (count-if (lambda (sibling)
 103                (pattern-thunk-matches-p count sibling))
 104              (xpath::force
 105               (funcall (xpath::axis-function :preceding-sibling) node)))))
 106
 107 (defun node-type (node)
 108   (dolist (type '(:element
 109                   :attribute
 110                   :text
 111                   :document
 112                   :namespace
 113                   :processing-instruction
 114                   :comment))
 115     (when (xpath-protocol:node-type-p node type)
 116       (return type))))
 117
 118 (defun compute-number-list (level node count from)
 119   (unless count
 120     (setf count
 121           (let ((uri (xpath-protocol:namespace-uri node))
 122                 (lname (xpath-protocol:local-name node))
 123                 (node-type (node-type node)))
 124             (lambda (pattern-node)
 125               (if (if (eq node-type :element)
 126                       (and (xpath-protocol:node-type-p pattern-node :element)
 127                            (equal (xpath-protocol:namespace-uri pattern-node)
 128                                   uri)
 129                            (equal (xpath-protocol:local-name pattern-node)
 130                                   lname))
 131                       (xpath-protocol:node-type-p pattern-node node-type))
 132                   (list t)
 133                   nil)))))
 134   (cond
 135     ((equal level "single")
 136      (let ((ancestor (car (ancestors-using-count-and-from node count from))))
 137        (if ancestor
 138            (list (node-position-among-siblings ancestor count))
 139            nil)))
 140     ((equal level "multiple")
 141      (mapcar (lambda (ancestor)
 142                (node-position-among-siblings ancestor count))
 143              (reverse
 144               (ancestors-using-count-and-from node count from))))
 145     ((equal level "any")
 146      (destructuring-bind (root)
 147          (xpath::force (funcall (xpath::axis-function :root) node))
 148        (let ((nodes (xpath::force
 149                      (xpath::append-pipes
 150                       (xpath::subpipe-before
 151                        node
 152                        (funcall (xpath::axis-function :descendant-or-self) root))
 153                       (list node)))))
 154          (when from
 155            (loop
 156               for (current . rest) on nodes
 157               when (pattern-thunk-matches-p from current)
 158               do
 159                 (setf nodes rest)))
 160          (list
 161           (loop
 162              for n in nodes
 163              count (pattern-thunk-matches-p count n))))))
 164     (t
 165      (xslt-error "invalid number level: ~A" level))))
 166
 167 (xpath::deflexer (format-lexer :ignore-whitespace nil)
 168   ;; zzz just enough unicode "support" here to pass the tests
 169   (#.(format nil "([a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :format x))
 170   (#.(format nil "([^a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :text x)))
 171
 172 (defun format-number-token (str n)
 173   (cond
 174     ((or (equal str "a")
 175          (equal str "A")
 176          ;; zzz just enough unicode "support" here to pass the tests
 177          (equal str #.(string (code-char 945))))
 178      (let ((start (char-code (elt str 0)))
 179            (greekp (equal str #.(string (code-char 945)))))
 180        (when (zerop n)
 181          (xslt-error "cannot format zero"))
 182        (nreverse
 183         (with-output-to-string (r)
 184           (loop
 185              for m = n then rest
 186              for (rest digit) = (multiple-value-list
 187                                  (truncate (1- m)
 188                                            (if greekp 25 26)))
 189              do
 190                (cond
 191                  ((plusp rest)
 192                   (write-char (code-char (+ start digit)) r))
 193                  (t
 194                   (write-char (code-char (+ start digit)) r)
 195                   (return))))))))
 196     ((equal str "i")
 197      (if (zerop n)
 198          "0"
 199          (format nil "~(~@R~)" n)))
 200     ((equal str "I")
 201      (if (zerop n)
 202          "0"
 203          (format nil "~@R" n)))
 204     (t
 205      (unless (cl-ppcre:all-matches "^0*1$" str)
 206        ;; unsupported format
 207        (setf str "1"))
 208      (format nil "~v,'0D" (length str) n))))
 209
 210 (defun group-numbers (str separator size stream)
 211   (loop
 212      for c across str
 213      for i from (1- (length str)) downto 0
 214      do
 215        (write-char c stream)
 216        (when (and (plusp size)
 217                   (and (zerop (mod i size)) (plusp i)))
 218          (write-string separator stream))))
 219
 220 ;;; fixme: unicode support
 221 (defun format-number-list
 222     (list format lang letter-value grouping-separator grouping-size)
 223   (declare (ignore lang letter-value))
 224   (if (some #'xpath::nan-p list)
 225       "NaN"
 226       (multiple-value-bind (prefix pairs suffix)
 227           (parse-number-format format)
 228         (with-output-to-string (s)
 229           (write-string prefix s)
 230           (loop
 231              for (separator . subformat) in pairs
 232              for n in (remove 0 list)
 233              for formatted = (format-number-token subformat n)
 234              do
 235              (when separator
 236                (write-string separator s))
 237              (if (and grouping-separator
 238                       grouping-size)
 239                  (group-numbers formatted
 240                                 grouping-separator
 241                                 grouping-size
 242                                 s)
 243                  (write-string formatted s)))
 244           (write-string suffix s)))))
 245
 246 (defun parse-number-format (format)
 247   (let ((lexer (format-lexer format))
 248         (prefix "")
 249         (conses '())
 250         (suffix "")
 251         (current-text nil))
 252     (loop
 253        (multiple-value-bind (type str) (funcall lexer)
 254          (ecase type
 255            ((nil :eof)
 256             (return))
 257            (:text
 258             (if conses
 259                 (setf current-text str)
 260                 (setf prefix str)))
 261            (:format
 262             (push (cons (if conses
 263                             (or current-text ".")
 264                             nil)
 265                         str)
 266                   conses)
 267             (setf current-text nil)))))
 268     (cond
 269       (current-text
 270        (setf suffix current-text))
 271       ((null conses)
 272        (setf suffix prefix)))
 273     (unless conses
 274       (setf conses (list (cons nil "1"))))
 275     (let* ((tail-cons (car conses))
 276            (tail (if (car tail-cons)
 277                      conses
 278                      (push (cons "." (cdr tail-cons)) conses))))
 279       (setf conses (nreverse conses))
 280       (setf (cdr tail) tail))
 281     (values prefix conses suffix)))