@@@ progfmt wip

[sod] / src / pset-proto.lisp

;;; -*-lisp-*-
;;;
;;; Protocol for property sets
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Property representation.

(export 'property-key)
(defun property-key (name)
  "Convert NAME into a keyword.

   If NAME isn't a symbol already, then flip its case (using
   `frob-identifier'), and intern into the `keyword' package."
  (etypecase name
    (symbol name)
    (string (intern (frob-identifier name) :keyword))))

(export '(property propertyp p-name p-value p-type p-key p-seenp))
(defstruct (property
	     (:predicate propertyp)
	     (:conc-name p-)
	     (:constructor %make-property
		 (name value
		  &key type location seenp
		  &aux (key (property-key name)) (%type type))))
  "A simple structure for holding a property in a property set.

   The main useful feature is the ability to tick off properties which have
   been used, so that we can complain about unrecognized properties.

   An explicit type tag is necessary because we need to be able to talk
   distinctly about identifiers, strings and symbols, and we've only got two
   obvious Lisp types to play with.  Sad, but true."

  (name nil :type (or string symbol) :read-only t)
  (value nil :type t :read-only t)
  (%type nil :type symbol :read-only t)
  (location (file-location nil) :type file-location :read-only t)
  (key nil :type symbol :read-only t)
  (seenp nil :type boolean))
(define-access-wrapper p-type p-%type :read-only t)

(export 'decode-property)
(defgeneric decode-property (raw)
  (:documentation "Decode a RAW value into a TYPE, VALUE pair.")
  (:method ((raw property)) (values (p-type raw) (p-value raw)))
  (:method ((raw cons)) (values (car raw) (cdr raw))))

(export 'make-property)
(defun make-property (name raw-value &key type location seenp)
  (multiple-value-bind (type value)
      (if type
	  (values type raw-value)
	  (decode-property raw-value))
    (%make-property name value
		    :type type
		    :location (file-location location)
		    :seenp seenp)))

(export 'coerce-property-value)
(defgeneric coerce-property-value (value type wanted)
  (:documentation
   "Convert VALUE, a property of type TYPE, to be of type WANTED.

   It's sensible to add additional methods to this function, but there are
   all the ones we need.")

  ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
  ;; form.  Otherwise, if nothing else matched, then I guess we'll have to
  ;; say it didn't work.
  (:method (value type wanted)
    (if (eql type wanted) value
	(error "Incorrect type: expected ~(~A~) but found ~(~A~)"
	       wanted type)))

  ;; If the caller asks for type T then give them the raw thing.
  (:method (value type (wanted (eql t)))
    (declare (ignore type))
    value))

;;;--------------------------------------------------------------------------
;;; Property set representation.

(export '(pset psetp))
(defstruct (pset (:predicate psetp)
		 (:constructor %make-pset)
		 (:conc-name %pset-))
  "A property set.

   Wrapped up in a structure so that we can define a print function."
  (hash (make-hash-table) :type hash-table))

(export '(make-pset pset-get pset-store pset-map))
(declaim (inline make-pset pset-get pset-store pset-map))

(defun make-pset ()
  "Constructor for property sets."
  (%make-pset))

(defun pset-get (pset key)
  "Look KEY up in PSET and return what we find.

   If there's no property by that name, return nil."
  (values (gethash key (%pset-hash pset))))

(defun pset-store (pset prop)
  "Store property PROP in PSET.

   Overwrite or replace any previous property with the same name.  Mutates
   the property set."
  (setf (gethash (p-key prop) (%pset-hash pset)) prop))

(defun pset-map (func pset)
  "Call FUNC for each property in PSET."
  (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
	   (%pset-hash pset)))

(export 'with-pset-iterator)
(defmacro with-pset-iterator ((name pset) &body body)
  "Evaluate BODY with NAME bound to a macro returning properties from PSET.

   Evaluating (NAME) returns a property object or nil if all properties have
   been read."
  (with-gensyms (next win key value)
    `(with-hash-table-iterator (,next (%pset-hash ,pset))
       (macrolet ((,name ()
		    `(multiple-value-bind (,',win ,',key ,',value) (,',next)
		      (declare (ignore ,',key))
		      (and ,',win ,',value))))
	 ,@body))))

;;;--------------------------------------------------------------------------
;;; `Cooked' property set operations.

(export 'store-property)
(defun store-property
    (pset name value &key type location)
  "Store a property in PSET."
  (pset-store pset
	      (make-property name value :type type :location location)))

(export 'get-property)
(defun get-property (pset name type &optional default)
  "Fetch a property from a property set.

   If a property NAME is not found in PSET, or if a property is found, but
   its type doesn't match TYPE, then return DEFAULT and nil; otherwise return
   the value and its file location.  In the latter case, mark the property as
   having been used.

   The value returned depends on the TYPE argument provided.  If you pass
   `nil' then you get back the entire `property' object.  If you pass `t',
   then you get whatever was left in the property set, uninterpreted.
   Otherwise the value is coerced to the right kind of thing (where possible)
   and returned.

   The file location at which the property was defined is returned as a
   second value.

   If PSET is nil, then return DEFAULT and nil."

  (let ((prop (and pset (pset-get pset (property-key name)))))
    (with-default-error-location ((and prop (p-location prop)))
      (cond ((not prop)
	     (values default nil))
	    ((not type)
	     (setf (p-seenp prop) t)
	     (values prop (p-location prop)))
	    (t
	     (setf (p-seenp prop) t)
	     (values (coerce-property-value (p-value prop)
					    (p-type prop)
					    type)
		     (p-location prop)))))))

(export 'add-property)
(defun add-property (pset name value &key type location)
  "Add a property to PSET.

   If a property with the same NAME already exists, report an error."

  (with-default-error-location (location)
    (let ((existing (get-property pset name nil)))
      (when existing
	(error "Property ~S already defined~@[ at ~A~]"
	       name (p-location existing)))
      (store-property pset name value :type type :location location))))

(export 'make-property-set)
(defun make-property-set (&rest plist)
  "Make a new property set, with given properties.

   This isn't the way to make properties when parsing, but it works well for
   programmatic generation.  The arguments should form a property list
   (alternating keywords and values is good).

   An attempt is made to guess property types from the Lisp types of the
   values.  This isn't always successful but it's not too bad.  The
   alternative is manufacturing a `property-value' object by hand and
   stuffing it into the set."

  (property-set plist))

(export 'property-set)
(defgeneric property-set (thing)
  (:documentation
   "Convert THING into a property set.")
  (:method ((pset pset)) pset)
  (:method ((list list))
    "Convert a list into a property set.  This works for alists and plists."
    (multiple-value-bind (next name value)
	(if (and list (consp (car list)))
	    (values #'cdr #'caar #'cdar)
	    (values #'cddr #'car #'cadr))
      (do ((pset (make-pset))
	   (list list (funcall next list)))
	  ((endp list) pset)
	(add-property pset (funcall name list) (funcall value list))))))

(export 'check-unused-properties)
(defun check-unused-properties (pset)
  "Issue errors about unused properties in PSET."
  (when pset
    (pset-map (lambda (prop)
		(unless (p-seenp prop)
		  (cerror*-with-location (p-location prop)
					 "Unknown property `~A'"
					 (p-name prop))
		  (setf (p-seenp prop) t)))
	      pset)))

;;;--------------------------------------------------------------------------
;;; Utility macros.

(export 'default-slot-from-property)
(defmacro default-slot-from-property
    ((instance slot &optional (slot-names t))
     (pset property type
      &optional (pvar (gensym "PROP-"))
      &rest convert-forms)
     &body default-forms)
  "Initialize a slot from a property.

   We initialize SLOT in INSTANCE.  In full: if PSET contains a property
   called NAME, then convert it to TYPE, bind the value to PVAR and evaluate
   CONVERT-FORMS -- these default to just using the property value.  If
   there's no property, and DEFAULT-FORMS contains at least one non-
   declaration form, and the slot is named in SLOT-NAMES and currently
   unbound, then evaluate DEFAULT-FORMS and use their value to compute the
   slot value."

  (once-only (instance slot slot-names pset property type)
    (multiple-value-bind (docs decls body)
	(parse-body default-forms :docp nil)
      (declare (ignore docs))
      (with-gensyms (floc)
	`(multiple-value-bind (,pvar ,floc)
	     (get-property ,pset ,property ,type)
	   ,@decls
	   (if ,floc
	       (setf (slot-value ,instance ,slot)
		     (with-default-error-location (,floc)
		       ,@(or convert-forms `(,pvar))))
	       ,@(and body
		      `((default-slot (,instance ,slot ,slot-names)
			  ,@body)))))))))

;;;----- That's all, folks --------------------------------------------------