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 (make-rmeta-slot
  25             maybe-build-rmeta-slot-cache!
  26             class-rmeta-ref))
  27
  28 ;;; This module is for rmeta-slots, aka a recursive-meta-slot.
  29 ;;;
  30 ;;; Recursive meta-slots are recursive because we walk down the
  31 ;;; inheritance list until we find a match, and meta because they
  32 ;;; are sort of "slots" of their own... alists, rather, where you
  33 ;;; are searching for the right key.
  34 ;;;
  35 ;;; Recursive meta-slots have their own cache so access is
  36 ;;; reasonably fast.
  37 ;;;
  38 ;;; A recursive meta-slot definition looks something like this:
  39 ;;;
  40 ;;;   ;; Define a class with a meta-slot
  41 ;;;   (define-class <kah-lassy> ()
  42 ;;;     (entries #:allocation #:each-subclass
  43 ;;;              #:init-value
  44 ;;;              (make-rmeta-slot
  45 ;;;               `((foo . "bar")
  46 ;;;                 (baz . "basil")))))
  47 ;;;
  48 ;;;   ;; Access values
  49 ;;;   (class-rmeta-ref <kah-lassy> 'entries 'foo) => "bar"
  50 ;;;   (class-rmeta-ref <kah-lassy> 'entries 'baz) => "basil"
  51 ;;;
  52 ;;;   ;; Define a subclass
  53 ;;;   (define-class <sub-lassy> (<kah-lassy>)
  54 ;;;     (entries #:allocation #:each-subclass
  55 ;;;              #:init-value
  56 ;;;              (make-rmeta-slot
  57 ;;;               `((foo . "foo2")
  58 ;;;                 (peanut . "gallery")))))
  59 ;;;
  60 ;;;   ;; Access values, and inheritance is preserved
  61 ;;;   (class-rmeta-ref <sub-lassy> 'entries 'foo) => "foo2"
  62 ;;;   (class-rmeta-ref <sub-lassy> 'entries 'peanut) => "gallery"
  63 ;;;   (class-rmeta-ref <sub-lassy> 'entries 'baz) => "basil"
  64
  65 (define-record-type <rmeta-slot>
  66   (%make-rmeta-slot table cache)
  67   rmeta-slot?
  68   (table rmeta-slot-table)
  69   (cache rmeta-slot-cache set-rmeta-slot-cache!))
  70
  71 (define (make-rmeta-slot table)
  72   (%make-rmeta-slot table #f))
  73
  74 ;; Immutable and unique
  75 (define %the-nothing (cons '*the* '*nothing*))
  76
  77 (define (maybe-build-rmeta-slot-cache! class slot-name
  78                                        equals? cache-set! cache-ref)
  79   "Build the rmeta slot cache, if it isn't built already."
  80   (define rmeta-slot
  81     (class-slot-ref class slot-name))
  82   (define (build-cache)
  83     (define cache (make-hash-table))
  84     (for-each
  85      (lambda (this-class)
  86        (and (class-slot-definition this-class slot-name)
  87             (class-slot-ref this-class slot-name)
  88             (let ((this-rmeta (class-slot-ref this-class slot-name)))
  89               (for-each (match-lambda
  90                           ((key . val)
  91                            ;; Add this value to the list if we haven't yet seen
  92                            ;; such a definition before
  93                            (when (eq? (cache-ref cache key %the-nothing)
  94                                       %the-nothing)
  95                              (cache-set! cache key val))))
  96                         (rmeta-slot-table this-rmeta)))))
  97      (class-precedence-list class))
  98     cache)
  99   ;; If it's alreayd built, this is a no-op.
 100   (when (not (rmeta-slot-cache rmeta-slot))
 101     (set-rmeta-slot-cache! rmeta-slot (build-cache))))
 102
 103 (define* (class-rmeta-ref class slot-name key
 104                           #:key (equals? eq?)
 105                           (cache-set! hashq-set!)
 106                           (cache-ref hashq-ref)
 107                           dflt)
 108   "Search heirarchy of CLASS through the rmeta-slot named SLOT-NAME for
 109 value matching KEY.  This also calls maybe-build-rmeta-slot-cache! as a side
 110 effect."
 111   (maybe-build-rmeta-slot-cache! class slot-name
 112                                  equals? cache-set! cache-ref)
 113   (cache-ref (rmeta-slot-cache (class-slot-ref class slot-name)) key dflt))