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