module/srfi/srfi-9/gnu.scm

   1 ;;; Extensions to SRFI-9
   2
   3 ;;      Copyright (C) 2010, 2012 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20
  21 ;; Extensions to SRFI-9. Fully documented in the Guile Reference Manual.
  22
  23 ;;; Code:
  24
  25 (define-module (srfi srfi-9 gnu)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (system base ck)
  28   #:export (set-record-type-printer!
  29             define-immutable-record-type
  30             set-field
  31             set-fields))
  32
  33 (define (set-record-type-printer! type proc)
  34   "Set PROC as the custom printer for TYPE."
  35   (struct-set! type vtable-index-printer proc))
  36
  37 (define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
  38   ((@@ (srfi srfi-9) %define-record-type)
  39    #t (define-immutable-record-type name ctor pred fields ...)
  40    name ctor pred fields ...))
  41
  42 (define-syntax-rule (set-field s (getter ...) expr)
  43   (%set-fields #t (set-field s (getter ...) expr) ()
  44                s ((getter ...) expr)))
  45
  46 (define-syntax-rule (set-fields s . rest)
  47   (%set-fields #t (set-fields s . rest) ()
  48                s . rest))
  49
  50 ;;
  51 ;; collate-set-field-specs is a helper for %set-fields
  52 ;; thats combines all specs with the same head together.
  53 ;;
  54 ;; For example:
  55 ;;
  56 ;;   SPECS:  (((a b c) expr1)
  57 ;;            ((a d)   expr2)
  58 ;;            ((b c)   expr3)
  59 ;;            ((c)     expr4))
  60 ;;
  61 ;;  RESULT:  ((a ((b c) expr1)
  62 ;;               ((d)   expr2))
  63 ;;            (b ((c)   expr3))
  64 ;;            (c (()    expr4)))
  65 ;;
  66 (define (collate-set-field-specs specs)
  67   (define (insert head tail expr result)
  68     (cond ((find (lambda (tree)
  69                    (free-identifier=? head (car tree)))
  70                  result)
  71            => (lambda (tree)
  72                 `((,head (,tail ,expr)
  73                          ,@(cdr tree))
  74                   ,@(delq tree result))))
  75           (else `((,head (,tail ,expr))
  76                   ,@result))))
  77   (with-syntax (((((head . tail) expr) ...) specs))
  78     (fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
  79
  80 (define-syntax unknown-getter
  81   (lambda (x)
  82     (syntax-case x ()
  83       ((_ orig-form getter)
  84        (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
  85
  86 (define-syntax c-list
  87   (lambda (x)
  88     (syntax-case x (quote)
  89       ((_ s 'v ...)
  90        #'(ck s '(v ...))))))
  91
  92 (define-syntax c-same-type-check
  93   (lambda (x)
  94     (syntax-case x (quote)
  95       ((_ s 'orig-form '(path ...)
  96           '(getter0 getter ...)
  97           '(type0 type ...)
  98           'on-success)
  99        (every (lambda (t g)
 100                 (or (free-identifier=? t #'type0)
 101                     (syntax-violation
 102                      'set-fields
 103                      (format #f
 104                              "\
 105 field paths ~a and ~a require one object to belong to two different record types (~a and ~a)"
 106                              (syntax->datum #`(path ... #,g))
 107                              (syntax->datum #'(path ... getter0))
 108                              (syntax->datum t)
 109                              (syntax->datum #'type0))
 110                      #'orig-form)))
 111               #'(type ...)
 112               #'(getter ...))
 113        #'(ck s 'on-success)))))
 114
 115 (define-syntax %set-fields
 116   (lambda (x)
 117     (with-syntax ((getter-type   #'(@@ (srfi srfi-9) getter-type))
 118                   (getter-index  #'(@@ (srfi srfi-9) getter-index))
 119                   (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
 120       (syntax-case x ()
 121         ((_ check? orig-form (path-so-far ...)
 122             s)
 123          #'s)
 124         ((_ check? orig-form (path-so-far ...)
 125             s (() e))
 126          #'e)
 127         ((_ check? orig-form (path-so-far ...)
 128             struct-expr ((head . tail) expr) ...)
 129          (let ((collated-specs (collate-set-field-specs
 130                                 #'(((head . tail) expr) ...))))
 131            (with-syntax (((getter0 getter ...)
 132                           (map car collated-specs)))
 133              (with-syntax ((err #'(unknown-getter
 134                                    orig-form getter0)))
 135                #`(ck
 136                   ()
 137                   (c-same-type-check
 138                    'orig-form
 139                    '(path-so-far ...)
 140                    '(getter0 getter ...)
 141                    (c-list (getter-type 'getter0 'err)
 142                            (getter-type 'getter 'err) ...)
 143                    '(let ((s struct-expr))
 144                       ((ck () (getter-copier 'getter0 'err))
 145                        check?
 146                        s
 147                        #,@(map (lambda (spec)
 148                                  (with-syntax (((head (tail expr) ...) spec))
 149                                    (with-syntax ((err #'(unknown-getter
 150                                                          orig-form head)))
 151                                      #'(head (%set-fields
 152                                               check?
 153                                               orig-form
 154                                               (path-so-far ... head)
 155                                               (struct-ref s (ck () (getter-index
 156                                                                     'head 'err)))
 157                                               (tail expr) ...)))))
 158                                collated-specs)))))))))
 159         ((_ check? orig-form (path-so-far ...)
 160             s (() e) (() e*) ...)
 161          (syntax-violation 'set-fields "duplicate field path"
 162                            #'orig-form #'(path-so-far ...)))
 163         ((_ check? orig-form (path-so-far ...)
 164             s ((getter ...) expr) ...)
 165          (syntax-violation 'set-fields "one field path is a prefix of another"
 166                            #'orig-form #'(path-so-far ...)))
 167         ((_ check? orig-form . rest)
 168          (syntax-violation 'set-fields "invalid syntax" #'orig-form))))))