8sync/rmeta-slot.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of 8sync.
   5 ;;;
   6 ;;; 8sync is free software: you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU Lesser General Public License as
   8 ;;; published by the Free Software Foundation, either version 3 of the
   9 ;;; License, or (at your option) any later version.
  10 ;;;
  11 ;;; 8sync is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU Lesser General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Lesser General Public
  17 ;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (8sync rmeta-slot)
  20   #:use-module (oop goops)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (ice-9 match)
  23
  24   #:export (wrap-rmeta-slot
  25             rmeta-slot-table rmeta-slot-cache
  26             maybe-build-rmeta-slot-cache!
  27             class-rmeta-ref))
  28
  29 ;;; This module is for rmeta-slots, aka a recursive-meta-slot.
  30 ;;;
  31 ;;; Recursive meta-slots are recursive because we walk down the
  32 ;;; inheritance list until we find a match, and meta because they
  33 ;;; are sort of "slots" of their own... alists, rather, where you
  34 ;;; are searching for the right key.
  35 ;;;
  36 ;;; Recursive meta-slots have their own cache so access is
  37 ;;; reasonably fast.
  38 ;;;
  39 ;;; A recursive meta-slot definition looks something like this:
  40 ;;;
  41 ;;;   ;; Define a class with a meta-slot
  42 ;;;   (define-class <kah-lassy> ()
  43 ;;;     (entries #:allocation #:each-subclass
  44 ;;;              #:init-thunk
  45 ;;;              (wrap-rmeta-slot
  46 ;;;               `((foo . "bar")
  47 ;;;                 (baz . "basil")))))
  48 ;;;
  49 ;;;   ;; Access values
  50 ;;;   (class-rmeta-ref <kah-lassy> 'entries 'foo) => "bar"
  51 ;;;   (class-rmeta-ref <kah-lassy> 'entries 'baz) => "basil"
  52 ;;;
  53 ;;;   ;; Define a subclass
  54 ;;;   (define-class <sub-lassy> (<kah-lassy>)
  55 ;;;     (entries #:allocation #:each-subclass
  56 ;;;              #:init-thunk
  57 ;;;              (wrap-rmeta-slot
  58 ;;;               `((foo . "foo2")
  59 ;;;                 (peanut . "gallery")))))
  60 ;;;
  61 ;;;   ;; Access values, and inheritance is preserved
  62 ;;;   (class-rmeta-ref <sub-lassy> 'entries 'foo) => "foo2"
  63 ;;;   (class-rmeta-ref <sub-lassy> 'entries 'peanut) => "gallery"
  64 ;;;   (class-rmeta-ref <sub-lassy> 'entries 'baz) => "basil"
  65
  66 (define-record-type <rmeta-slot>
  67   (%make-rmeta-slot table cache)
  68   rmeta-slot?
  69   (table rmeta-slot-table)
  70   (cache rmeta-slot-cache set-rmeta-slot-cache!))
  71
  72 (define (make-rmeta-slot table)
  73   (%make-rmeta-slot table #f))
  74
  75 (define (wrap-rmeta-slot table)
  76   "In general, using wrap-rmeta-slot in combination with "
  77   (lambda ()
  78     (make-rmeta-slot table)))
  79
  80 ;; Immutable and unique
  81 (define %the-nothing (cons '*the* '*nothing*))
  82
  83 (define (maybe-build-rmeta-slot-cache! class slot-name
  84                                        equals? cache-set! cache-ref)
  85   "Build the rmeta slot cache, if it isn't built already."
  86   (define rmeta-slot
  87     (class-slot-ref class slot-name))
  88   (define (build-cache)
  89     (define cache (make-hash-table))
  90     (for-each
  91      (lambda (this-class)
  92        (and (class-slot-definition this-class slot-name)
  93             (class-slot-ref this-class slot-name)
  94             (let ((this-rmeta (class-slot-ref this-class slot-name)))
  95               (for-each (match-lambda
  96                           ((key . val)
  97                            ;; Add this value to the list if we haven't yet seen
  98                            ;; such a definition before
  99                            (when (eq? (cache-ref cache key %the-nothing)
 100                                       %the-nothing)
 101                              (cache-set! cache key val))))
 102                         (rmeta-slot-table this-rmeta)))))
 103      (class-precedence-list class))
 104     cache)
 105   ;; If it's alreayd built, this is a no-op.
 106   (when (not (rmeta-slot-cache rmeta-slot))
 107     (set-rmeta-slot-cache! rmeta-slot (build-cache))))
 108
 109 (define* (class-rmeta-ref class slot-name key
 110                           #:key (equals? equal?)
 111                           (cache-set! hash-set!)
 112                           (cache-ref hash-ref)
 113                           dflt)
 114   "Search heirarchy of CLASS through the rmeta-slot named SLOT-NAME for
 115 value matching KEY.  This also calls maybe-build-rmeta-slot-cache! as a side
 116 effect."
 117   (maybe-build-rmeta-slot-cache! class slot-name
 118                                  equals? cache-set! cache-ref)
 119   (cache-ref (rmeta-slot-cache (class-slot-ref class slot-name)) key dflt))