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 (build-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 ;;;              (build-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 ;;;              (build-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 (build-rmeta-slot table)
  73   (lambda ()
  74     (%make-rmeta-slot table #f)))
  75
  76 ;; Immutable and unique
  77 (define %the-nothing (cons '*the* '*nothing*))
  78
  79 (define (maybe-build-rmeta-slot-cache! class slot-name
  80                                        equals? cache-set! cache-ref)
  81   "Build the rmeta slot cache, if it isn't built already."
  82   (define rmeta-slot
  83     (class-slot-ref class slot-name))
  84   (define (build-cache)
  85     (define cache (make-hash-table))
  86     (for-each
  87      (lambda (this-class)
  88        (and (class-slot-definition this-class slot-name)
  89             (class-slot-ref this-class slot-name)
  90             (let ((this-rmeta (class-slot-ref this-class slot-name)))
  91               (for-each (match-lambda
  92                           ((key . val)
  93                            ;; Add this value to the list if we haven't yet seen
  94                            ;; such a definition before
  95                            (when (eq? (cache-ref cache key %the-nothing)
  96                                       %the-nothing)
  97                              (cache-set! cache key val))))
  98                         (rmeta-slot-table this-rmeta)))))
  99      (class-precedence-list class))
 100     cache)
 101   ;; If it's alreayd built, this is a no-op.
 102   (when (not (rmeta-slot-cache rmeta-slot))
 103     (set-rmeta-slot-cache! rmeta-slot (build-cache))))
 104
 105 (define* (class-rmeta-ref class slot-name key
 106                           #:key (equals? equal?)
 107                           (cache-set! hash-set!)
 108                           (cache-ref hash-ref)
 109                           dflt)
 110   "Search heirarchy of CLASS through the rmeta-slot named SLOT-NAME for
 111 value matching KEY.  This also calls maybe-build-rmeta-slot-cache! as a side
 112 effect."
 113   (maybe-build-rmeta-slot-cache! class slot-name
 114                                  equals? cache-set! cache-ref)
 115   (cache-ref (rmeta-slot-cache (class-slot-ref class slot-name)) key dflt))