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
 240 (defmethod type-library ((type xsd-type))
 241   :|http://www.w3.org/2001/XMLSchema-datatypes|)
 242
 243 (defmethod find-type
 244     ((library (eql :|http://www.w3.org/2001/XMLSchema-datatypes|))
 245      name
 246      &rest args &key)
 247   args                                  ;fixme
 248   (case (find-symbol name :keyword)
 249     (:|QName| (make-instance 'qname-type))
 250     (:|NCName| (make-instance 'ncname-type))
 251     (:|anyURI| (make-instance 'any-uri-type))
 252     (t nil)))
 253
 254 (defgeneric %parse (type e context))
 255
 256 (defmethod validp ((type xsd-type) e &optional context)
 257   (not (eq :error (%parse type e context))))
 258
 259 (defmethod parse ((type xsd-type) e &optional context)
 260   (let ((result (%parse type e context)))
 261     (when (eq result :error)
 262       (error "not valid for data type ~A: ~S" type e))
 263     result))
 264
 265
 266 ;;; QName
 267
 268 (defclass qname-type (xsd-type) ())
 269
 270 (defmethod type-name ((type qname-type))
 271   "QName")
 272
 273 (defstruct (qname (:constructor make-qname (uri lname)))
 274   uri
 275   lname)
 276
 277 (defmethod equal-using-type ((type qname-type) u v)
 278   (and (equal (qname-uri u) (qname-uri v))
 279        (equal (qname-lname u) (qname-lname v))))
 280
 281 (defun namep (str)
 282   (every #'cxml::name-rune-p str))
 283
 284 (defmethod %parse ((type qname-type) e context)
 285   (setf e (normalize-whitespace e))
 286   (handler-case
 287       (if (namep e)
 288           (multiple-value-bind (prefix local-name) (cxml::split-qname e)
 289             (let ((uri (when prefix
 290                          (context-find-namespace-binding context prefix))))
 291               (if (and prefix (not uri))
 292                   :error
 293                   (make-qname uri local-name))))
 294           :error)
 295     (cxml:well-formedness-violation ()
 296       :error)))
 297
 298
 299 ;;; NCName
 300
 301 (defclass ncname-type (xsd-type) ())
 302
 303 (defmethod type-name ((type ncname-type))
 304   "NCName")
 305
 306 (defmethod equal-using-type ((type ncname-type) u v)
 307   (equal u v))
 308
 309 (defun nc-name-p (str)
 310   (and (namep str) (cxml::nc-name-p str)))
 311
 312 (defmethod %parse ((type ncname-type) e context)
 313   (setf e (normalize-whitespace e))
 314   (if (nc-name-p e)
 315       e
 316       :error))
 317
 318
 319 ;;; AnyURi
 320
 321 (defclass any-uri-type (xsd-type) ())
 322
 323 (defmethod type-name ((type any-uri-type))
 324   "AnyURI")
 325
 326 (defmethod equal-using-type ((type any-uri-type) u v)
 327   (equal u v))
 328
 329 (defmethod %parse ((type any-uri-type) e context)
 330   (setf e (normalize-whitespace e))
 331   (cxml-rng::escape-uri e))