types.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-types)
  30
  31 (defclass data-type () ()
  32   (:documentation
  33    "@short{The abstract superclass of all types.}
  34
  35     Each type belongs to a datatype library, named by a keyword.  In each
  36     library, the types are named by strings.
  37
  38     @see{find-type}
  39     @see{type-name}
  40     @see{type-library}
  41     @see{type-context-dependent-p}
  42     @see{parse}
  43     @see{equal-using-type}
  44     @see{validp}"))
  45
  46 (defgeneric find-type (library name &key &allow-other-keys)
  47   (:documentation
  48    "@arg[library]{datatype library, a keyword symbol}
  49     @arg[name]{the type's name, a string}
  50     @arg[args]{type parameters, strings named by keyword arguments}
  51     @return{an instance of @class{data-type}, or @code{nil}}
  52     @short{Look up the type named @em{name} in datatype library @em{library}.}
  53
  54     Return a type instance for this type and the additional parameters,
  55     or @code{nil} if the type does not exist.
  56
  57     Additional parameters (knows as facets in XSD) can be passed to specify
  58     or restrict the type for the purposes of @fun{validp}.
  59
  60     @see{data-type}"))
  61
  62 (defgeneric type-library (type)
  63   (:documentation
  64    "@arg[type]{an instance of @class{data-type}}
  65     @return{library name, a keyword}
  66     @short{Return the name of the library this type belongs to.}
  67
  68     @see{type-name}
  69     @see{type-context-dependent-p}"))
  70
  71 (defgeneric type-name (type)
  72   (:documentation
  73    "@arg[type]{an instance of @class{data-type}}
  74     @return{type name, a string}
  75     @short{Return the name this type has within its library.}
  76
  77     @see{type-library}
  78     @see{type-context-dependent-p}"))
  79
  80 (defmethod find-type ((library t) name &key &allow-other-keys)
  81   (declare (ignore name))
  82   nil)
  83
  84 (defgeneric type-context-dependent-p (type)
  85   (:documentation
  86    "@arg[type]{an instance of @class{data-type}}
  87     @return{a boolean}
  88     @short{Return true if parsing and validation of values by this type
  89       depends on the validation context.}
  90
  91     In this case, the optional @code{context} argument to @fun{parse} and
  92     @fun{validp} is required, and an error will be signalled if it is missing.
  93
  94     @see{type-name}
  95     @see{type-library}
  96     @see{type-context-dependent-p}"))
  97
  98 (defmethod type-context-dependent-p ((type data-type))
  99   nil)
 100
 101 (defgeneric equal-using-type (type u v)
 102   (:documentation
 103    "@arg[type]{an instance of @class{data-type}}
 104     @arg[u]{a parsed value as returned by @fun{parse}}
 105     @arg[v]{a parsed value as returned by @fun{parse}}
 106     @return{a boolean}
 107     @short{Compare the @emph{values} @code{u} and @code{v} using a
 108       data-type-dependent equality function.}
 109
 110     @see{parse}
 111     @see{validp}"))
 112
 113 (defgeneric parse (type e &optional context)
 114   (:documentation
 115    "@arg[type]{an instance of @class{data-type}}
 116     @arg[e]{a string}
 117     @arg[context]{an instance of @class{validation-context}}
 118     @return{an object}
 119     @short{Parse string @code{e} and return a representation of its value
 120       as defined by the data type.}
 121
 122     The @code{context} argument is required if @fun{type-context-dependent-p}
 123     is true for @code{type}, and will be ignored otherwise.
 124
 125     @see{equal-using-type}
 126     @see{validp}"))
 127
 128 (defgeneric validp (type e &optional context)
 129   (:documentation
 130    "@arg[type]{an instance of @class{data-type}}
 131     @arg[e]{a string}
 132     @arg[context]{an instance of @class{validation-context}}
 133     @return{a boolean}
 134     @short{Determine whether a string is a valid lexical representation
 135     for a type.}
 136
 137     The @code{context} argument is required if @fun{type-context-dependent-p}
 138     is true for @code{type}, and will be ignored otherwise.
 139
 140     @see{parse}
 141     @see{equal-using-type}"))
 142
 143
 144 ;;; Validation context
 145
 146 (defclass validation-context () ())
 147
 148 (defgeneric context-find-namespace-binding (context prefix)
 149   (:documentation
 150    "@arg[context]{an instance of @class{validation-context}}
 151     @arg[prefix]{qname prefix, a string}
 152     @return{the namespace URI as a string, or NIL}"))
 153
 154 (defclass klacks-validation-context (validation-context)
 155   ((source :initarg :source :accessor context-source)))
 156
 157 (defun make-klacks-validation-context (source)
 158   (make-instance 'klacks-validation-context :source source))
 159
 160 (defmethod context-find-namespace-binding
 161     ((context klacks-validation-context) prefix)
 162   (klacks:find-namespace-binding prefix (context-source context)))
 163
 164 (defclass sax-validation-context-mixin (validation-context)
 165   ((stack :initform nil :accessor context-stack)))
 166
 167 (defmethod sax:start-prefix-mapping
 168     ((handler sax-validation-context-mixin) prefix uri)
 169   (push (cons prefix uri) (context-stack handler)))
 170
 171 (defmethod sax:end-prefix-mapping
 172     ((handler sax-validation-context-mixin) prefix)
 173   (setf (context-stack handler)
 174         (remove prefix
 175                 (context-stack handler)
 176                 :count 1
 177                 :key #'car
 178                 :test #'equal)))
 179
 180 (defmethod context-find-namespace-binding
 181     ((context sax-validation-context-mixin) prefix)
 182   (cdr (assoc prefix (context-stack context) :test #'equal)))
 183
 184
 185 ;;; Relax NG built-in type library
 186
 187 (defclass rng-type (data-type) ())
 188 (defclass string-type (rng-type) ())
 189 (defclass token-type (rng-type) ())
 190
 191 (defmethod type-library ((type rng-type))
 192   :||)
 193
 194 (defvar *string-data-type* (make-instance 'string-type))
 195 (defvar *token-data-type* (make-instance 'token-type))
 196
 197 (defmethod find-type ((library (eql :||)) name &rest args &key)
 198   (cond
 199     (args nil)
 200     ((equal name "string") *string-data-type*)
 201     ((equal name "token") *token-data-type*)
 202     (t nil)))
 203
 204 (defmethod equal-using-type ((type rng-type) u v)
 205   (equal u v))
 206
 207 (defmethod validp ((type rng-type) e &optional context)
 208   (declare (ignore e context))
 209   t)
 210
 211 (defmethod type-name ((type string-type)) "string")
 212 (defmethod type-name ((type token-type)) "token")
 213
 214 (defmethod parse ((type string-type) e &optional context)
 215   (declare (ignore context))
 216   e)
 217
 218 (defmethod parse ((type token-type) e &optional context)
 219   (declare (ignore context))
 220   (normalize-whitespace e))
 221
 222 (eval-when (:compile-toplevel :load-toplevel :execute)
 223   (defparameter *whitespace*
 224     (format nil "~C~C~C~C"
 225             (code-char 9)
 226             (code-char 32)
 227             (code-char 13)
 228             (code-char 10))))
 229
 230 (defun normalize-whitespace (str)
 231   (cl-ppcre:regex-replace-all #.(format nil "[~A]+" *whitespace*)
 232                               (string-trim *whitespace* str)
 233                               " "))
 234
 235
 236 ;;; XML Schema Part 2: Datatypes Second Edition
 237
 238 (defclass xsd-type (data-type)
 239   ((min-length :initarg :min-length :accessor min-length)))
 240
 241 (defmethod initialize-instance ((instance xsd-type)
 242                                 &rest args
 243                                 &key ((:min\length min-length))
 244                                      ((:max\length max-length)))
 245   (apply #'call-next-method
 246          instance
 247          :min-length (when min-length
 248                        ;; fixme: richtigen fehler
 249                        (parse-integer min-length))
 250          args))
 251
 252 (defmethod type-library ((type xsd-type))
 253   :|http://www.w3.org/2001/XMLSchema-datatypes|)
 254
 255 (defmethod find-type
 256     ((library (eql :|http://www.w3.org/2001/XMLSchema-datatypes|))
 257      name
 258      &rest args &key)
 259   args                                  ;fixme
 260   (let ((class
 261          (case (find-symbol name :keyword)
 262            (:|QName| 'qname-type)
 263            (:|NCName| 'ncname-type)
 264            (:|anyURI| 'any-uri-type)
 265            (:|string| 'xsd-string-type)
 266            (t nil))))
 267     (if class
 268         (apply #'make-instance class args)
 269         nil)))
 270
 271 (defgeneric %parse (type e context))
 272
 273 (defmethod validp ((type xsd-type) e &optional context)
 274   (not (eq :error (%parse type e context))))
 275
 276 (defmethod parse ((type xsd-type) e &optional context)
 277   (let ((result (%parse type e context)))
 278     (when (eq result :error)
 279       (error "not valid for data type ~A: ~S" type e))
 280     result))
 281
 282
 283 ;;; QName
 284
 285 (defclass qname-type (xsd-type) ())
 286
 287 (defmethod type-name ((type qname-type))
 288   "QName")
 289
 290 (defstruct (qname (:constructor make-qname (uri lname)))
 291   uri
 292   lname)
 293
 294 (defmethod equal-using-type ((type qname-type) u v)
 295   (and (equal (qname-uri u) (qname-uri v))
 296        (equal (qname-lname u) (qname-lname v))))
 297
 298 (defun namep (str)
 299   (every #'cxml::name-rune-p str))
 300
 301 (defmethod %parse ((type qname-type) e context)
 302   (setf e (normalize-whitespace e))
 303   (handler-case
 304       (if (namep e)
 305           (multiple-value-bind (prefix local-name) (cxml::split-qname e)
 306             (let ((uri (when prefix
 307                          (context-find-namespace-binding context prefix))))
 308               (if (and prefix (not uri))
 309                   :error
 310                   (make-qname uri local-name))))
 311           :error)
 312     (cxml:well-formedness-violation ()
 313       :error)))
 314
 315
 316 ;;; NCName
 317
 318 (defclass ncname-type (xsd-type) ())
 319
 320 (defmethod type-name ((type ncname-type))
 321   "NCName")
 322
 323 (defmethod equal-using-type ((type ncname-type) u v)
 324   (equal u v))
 325
 326 (defun nc-name-p (str)
 327   (and (namep str) (cxml::nc-name-p str)))
 328
 329 (defmethod %parse ((type ncname-type) e context)
 330   (setf e (normalize-whitespace e))
 331   (if (nc-name-p e)
 332       e
 333       :error))
 334
 335
 336 ;;; AnyURi
 337
 338 (defclass any-uri-type (xsd-type) ())
 339
 340 (defmethod type-name ((type any-uri-type))
 341   "AnyURI")
 342
 343 (defmethod equal-using-type ((type any-uri-type) u v)
 344   (equal u v))
 345
 346 (defmethod %parse ((type any-uri-type) e context)
 347   (setf e (normalize-whitespace e))
 348   (cxml-rng::escape-uri e))
 349
 350
 351 ;;; string
 352
 353 (defclass xsd-string-type (xsd-type) ())
 354
 355 (defmethod type-name ((type xsd-string-type))
 356   "string")
 357
 358 (defmethod equal-using-type ((type xsd-string-type) u v)
 359   (equal u v))
 360
 361 (defmethod %parse ((type xsd-string-type) e context)
 362   (if (and (min-length type) (< (length e) (min-length type)))
 363       :error
 364       e))