chiark - git - mdw - sod/blob - src/pset-proto.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Protocol for property sets
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Property representation.
  30
  31 (export 'property-key)
  32 (defun property-key (name)
  33   "Convert NAME into a keyword.
  34
  35    If NAME isn't a symbol already, then flip its case (using
  36    `frob-identifier'), and intern into the `keyword' package."
  37   (etypecase name
  38     (symbol name)
  39     (string (intern (frob-identifier name) :keyword))))
  40
  41 (export '(property propertyp p-name p-value p-type p-key p-seenp))
  42 (defstruct (property
  43              (:predicate propertyp)
  44              (:conc-name p-)
  45              (:constructor %make-property
  46                            (name value
  47                             &key type location seenp
  48                             &aux (key (property-key name)))))
  49   "A simple structure for holding a property in a property set.
  50
  51    The main useful feature is the ability to tick off properties which have
  52    been used, so that we can complain about unrecognized properties.
  53
  54    An explicit type tag is necessary because we need to be able to talk
  55    distinctly about identifiers, strings and symbols, and we've only got two
  56    obvious Lisp types to play with.  Sad, but true."
  57
  58   (name nil :type (or string symbol))
  59   (value nil :type t)
  60   (type nil :type symbol)
  61   (location (file-location nil) :type file-location)
  62   (key nil :type symbol)
  63   (seenp nil :type boolean))
  64
  65 (export 'decode-property)
  66 (defgeneric decode-property (raw)
  67   (:documentation "Decode a RAW value into a TYPE, VALUE pair.")
  68   (:method ((raw symbol)) (values :symbol raw))
  69   (:method ((raw integer)) (values :int raw))
  70   (:method ((raw string)) (values :string raw))
  71   (:method ((raw character)) (values :char raw))
  72   (:method ((raw property)) (values (p-type raw) (p-value raw)))
  73   (:method ((raw cons)) (values (car raw) (cdr raw)))
  74   (:method ((raw function)) (values :func raw)))
  75
  76 (export 'make-property)
  77 (defun make-property (name raw-value &key type location seenp)
  78   (multiple-value-bind (type value)
  79       (if type
  80           (values type raw-value)
  81           (decode-property raw-value))
  82     (%make-property name value
  83                     :type type
  84                     :location (file-location location)
  85                     :seenp seenp)))
  86
  87 (defun string-to-symbol
  88     (string &key (package *package*) (swap-case t) (swap-hyphen t))
  89   "Convert STRING to a symbol in PACKAGE.
  90
  91    Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the
  92    package; PACKAGE is used if there isn't a prefix.  A doubled colon allows
  93    access to internal symbols, and will intern if necessary.  Note that
  94    escape characters are /not/ processed; don't put colons in package names
  95    if you want to use them from SOD property sets.
  96
  97    The portions of the string are modified by `frob-identifier'; the
  98    arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to
  99    control this process."
 100
 101   (let* ((length (length string))
 102          (colon (position #\: string)))
 103     (multiple-value-bind (start internalp)
 104         (cond ((not colon) (values 0 t))
 105               ((and (< (1+ colon) length)
 106                     (char= (char string (1+ colon)) #\:))
 107                (values (+ colon 2) t))
 108               (t
 109                (values (1+ colon) nil)))
 110       (when colon
 111         (let* ((package-name (if (zerop colon) "KEYWORD"
 112                                  (frob-identifier (subseq string 0 colon)
 113                                                   :swap-case swap-case
 114                                                   :swap-hyphen swap-hyphen)))
 115                (found (find-package package-name)))
 116           (unless found
 117             (error "Unknown package `~A'" package-name))
 118           (setf package found)))
 119       (let ((name (frob-identifier (subseq string start)
 120                                    :swap-case swap-case
 121                                    :swap-hyphen swap-hyphen)))
 122         (multiple-value-bind (symbol status)
 123             (funcall (if internalp #'intern #'find-symbol) name package)
 124           (cond ((or internalp (eq status :external))
 125                  symbol)
 126                 ((not status)
 127                  (error "Symbol `~A' not found in package `~A'"
 128                         name (package-name package)))
 129                 (t
 130                  (error "Symbol `~A' not external in package `~A'"
 131                         name (package-name package)))))))))
 132
 133 (export 'coerce-property-value)
 134 (defgeneric coerce-property-value (value type wanted)
 135   (:documentation
 136    "Convert VALUE, a property of type TYPE, to be of type WANTED.
 137
 138    It's sensible to add additional methods to this function, but there are
 139    all the ones we need.")
 140
 141   ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
 142   ;; form.  Otherwise, if nothing else matched, then I guess we'll have to
 143   ;; say it didn't work.
 144   (:method (value type wanted)
 145     (if (eql type wanted) value
 146         (error "Incorrect type: expected ~A but found ~A" wanted type)))
 147
 148   ;; If the caller asks for type T then give him the raw thing.
 149   (:method (value type (wanted (eql t)))
 150     (declare (ignore type))
 151     value))
 152
 153 ;;;--------------------------------------------------------------------------
 154 ;;; Property set representation.
 155
 156 (export '(pset psetp))
 157 (defstruct (pset (:predicate psetp)
 158                  (:constructor %make-pset)
 159                  (:conc-name %pset-))
 160   "A property set.
 161
 162    Wrapped up in a structure so that we can define a print function."
 163   (hash (make-hash-table) :type hash-table))
 164
 165 (export '(make-pset pset-get pset-store pset-map))
 166 (declaim (inline make-pset pset-get pset-store pset-map))
 167
 168 (defun make-pset ()
 169   "Constructor for property sets."
 170   (%make-pset))
 171
 172 (defun pset-get (pset key)
 173   "Look KEY up in PSET and return what we find.
 174
 175    If there's no property by that name, return NIL."
 176   (values (gethash key (%pset-hash pset))))
 177
 178 (defun pset-store (pset prop)
 179   "Store property PROP in PSET.
 180
 181    Overwrite or replace any previous property with the same name.  Mutates
 182    the property set."
 183   (setf (gethash (p-key prop) (%pset-hash pset)) prop))
 184
 185 (defun pset-map (func pset)
 186   "Call FUNC for each property in PSET."
 187   (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
 188            (%pset-hash pset)))
 189
 190 (export 'with-pset-iterator)
 191 (defmacro with-pset-iterator ((name pset) &body body)
 192   "Evaluate BODY with NAME bound to a macro returning properties from PSET.
 193
 194    Evaluating (NAME) returns a property object or nil if all properties have
 195    been read."
 196   (with-gensyms (next win key value)
 197     `(with-hash-table-iterator (,next (%pset-hash ,pset))
 198        (macrolet ((,name ()
 199                     `(multiple-value-bind (,',win ,',key ,',value) (,',next)
 200                       (declare (ignore ,',key))
 201                       (and ,',win ,',value))))
 202          ,@body))))
 203
 204 ;;;--------------------------------------------------------------------------
 205 ;;; `Cooked' property set operations.
 206
 207 (export 'store-property)
 208 (defun store-property
 209     (pset name value &key type location)
 210   "Store a property in PSET."
 211   (pset-store pset
 212               (make-property name value :type type :location location)))
 213
 214 (export 'get-property)
 215 (defun get-property (pset name type &optional default)
 216   "Fetch a property from a property set.
 217
 218    If a property NAME is not found in PSET, or if a property is found, but
 219    its type doesn't match TYPE, then return DEFAULT and nil; otherwise return
 220    the value and its file location.  In the latter case, mark the property as
 221    having been used.
 222
 223    The value returned depends on the TYPE argument provided.  If you pass
 224    `nil' then you get back the entire `property' object.  If you pass `t',
 225    then you get whatever was left in the property set, uninterpreted.
 226    Otherwise the value is coerced to the right kind of thing (where possible)
 227    and returned.
 228
 229    The file location at which the property was defined is returned as a
 230    second value.
 231
 232    If PSET is nil, then return DEFAULT and nil."
 233
 234   (let ((prop (and pset (pset-get pset (property-key name)))))
 235     (with-default-error-location ((and prop (p-location prop)))
 236       (cond ((not prop)
 237              (values default nil))
 238             ((not type)
 239              (setf (p-seenp prop) t)
 240              (values prop (p-location prop)))
 241             (t
 242              (setf (p-seenp prop) t)
 243              (values (coerce-property-value (p-value prop)
 244                                             (p-type prop)
 245                                             type)
 246                      (p-location prop)))))))
 247
 248 (export 'add-property)
 249 (defun add-property (pset name value &key type location)
 250   "Add a property to PSET.
 251
 252    If a property with the same NAME already exists, report an error."
 253
 254   (with-default-error-location (location)
 255     (let ((existing (get-property pset name nil)))
 256       (when existing
 257         (error "Property ~S already defined~@[ at ~A~]"
 258                name (p-location existing)))
 259       (store-property pset name value :type type :location location))))
 260
 261 (export 'make-property-set)
 262 (defun make-property-set (&rest plist)
 263   "Make a new property set, with given properties.
 264
 265    This isn't the way to make properties when parsing, but it works well for
 266    programmatic generation.  The arguments should form a property list
 267    (alternating keywords and values is good).
 268
 269    An attempt is made to guess property types from the Lisp types of the
 270    values.  This isn't always successful but it's not too bad.  The
 271    alternative is manufacturing a `property-value' object by hand and
 272    stuffing it into the set."
 273
 274   (property-set plist))
 275
 276 (export 'property-set)
 277 (defgeneric property-set (thing)
 278   (:documentation
 279    "Convert THING into a property set.")
 280   (:method ((pset pset)) pset)
 281   (:method ((list list))
 282     "Convert a list into a property set.  This works for alists and plists."
 283     (multiple-value-bind (next name value)
 284         (if (and list (consp (car list)))
 285             (values #'cdr #'caar #'cdar)
 286             (values #'cddr #'car #'cadr))
 287       (do ((pset (make-pset))
 288            (list list (funcall next list)))
 289           ((endp list) pset)
 290         (add-property pset (funcall name list) (funcall value list))))))
 291
 292 (export 'check--unused-properties)
 293 (defun check-unused-properties (pset)
 294   "Issue errors about unused properties in PSET."
 295   (when pset
 296     (pset-map (lambda (prop)
 297                 (unless (p-seenp prop)
 298                   (cerror*-with-location (p-location prop)
 299                                          "Unknown property `~A'"
 300                                          (p-name prop))
 301                   (setf (p-seenp prop) t)))
 302               pset)))
 303
 304 ;;;--------------------------------------------------------------------------
 305 ;;; Utility macros.
 306
 307 (defmacro default-slot-from-property
 308     ((instance slot slot-names)
 309      (pset property type
 310       &optional (pvar (gensym "PROP-"))
 311       &rest convert-forms)
 312      &body default-forms)
 313   "Initialize a slot from a property.
 314
 315    We initialize SLOT in INSTANCE.  In full: if PSET contains a property
 316    called NAME, then convert it to TYPE, bind the value to PVAR and evaluate
 317    CONVERT-FORMS -- these default to just using the property value.  If
 318    there's no property, and the slot is named in SLOT-NAMES and currently
 319    unbound, then evaluate DEFAULT-FORMS and use their value to compute the
 320    slot value."
 321
 322   (once-only (instance slot slot-names pset property type)
 323     (with-gensyms (floc)
 324       `(multiple-value-bind (,pvar ,floc)
 325            (get-property ,pset ,property ,type)
 326          (if ,floc
 327              (setf (slot-value ,instance ,slot)
 328                    (with-default-error-location (,floc)
 329                      ,@(or convert-forms `(,pvar))))
 330              (default-slot (,instance ,slot ,slot-names)
 331                ,@default-forms))))))
 332
 333 ;;;----- That's all, folks --------------------------------------------------