;;; -*- Mode: Scheme -*-

;;;; Variant Record Types

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

;;; This is compatible with TRC's analogous facility for Scheme48, at
;;; <http://mumble.net/~campbell/scheme/s48-variant-type.scm>.
;;;
;;; This file relies on TRC's integer enumeration facility for MIT
;;; Scheme, at <http://mumble.net/~campbell/scheme/mit-defenum.scm>.
;;; This file also requires a patch to MIT Scheme's syntactic closures
;;; facility to fix a bug; evaluate this definition in the (RUNTIME
;;; SYNTACTIC-CLOSURES) environment:
;;;
;;;   (define (syntactic-binding-theory environment name item history)
;;;     (if (not (keyword-item? item))
;;;         (let ((history (item/history item)))
;;;           (syntax-error history
;;;                         "Syntactic binding value must be a keyword:"
;;;                         (history/original-form history))))
;;;     (syntactic-environment/define environment name
;;;                                   (item/new-history item #f))
;;;     (if (and (keyword-value-item? item)
;;;              (syntactic-environment/top-level? environment))
;;;         (make-binding-item history
;;;                            ;** This was just NAME before.
;;;                            (rename-top-level-identifier name)
;;;                            item)
;;;         (make-null-binding-item history)))
;;;
;;; Learn by example because I'm too lazy to document:
;;;
;;;   (define-variant-type option <option> option?
;;;       option-case
;;;     (variant ABSENT (make-absent-option))
;;;     (variant SUPPLIED (make-supplied-option value)))
;;;
;;;   ;; OPTION-CASE &c. are defined by the above, so, e.g.:
;;;
;;;   (option-case (make-supplied-option 3)
;;;     ((ABSENT) ...)
;;;     ((SUPPLIED value) ...))
;;;
;;; The VARIANT noise word in DEFINE-VARIANT-TYPE is designed to allow
;;; for future extensions, such as a FIELD noise word for fields common
;;; to all of the variants:
;;;
;;;   (define-variant-type node :node node?
;;;       node-case
;;;     (field parent node-parent)
;;;     (variant LAMBDA (make-lambda bvl body))
;;;     (variant CALL (make-call operator operands))
;;;     (variant LITERAL (make-literal datum))
;;;     (variant REFERENCE (make-reference variable))
;;;
;;; There is no support for nested variant record matching, or any kind
;;; of general pattern matching.  Sorry.  This works for my needs.
;;;
;;; Direct questions, comments, bugs, disparagement of aesthetics, &c.,
;;; to the user on net.mumble (in little-endian order) whose name is
;;; campbell, or to Riastradh in the #scheme IRC channel on the
;;; Freenode network (irc.freenode.net).
;;;
;;; Pretty indentation:
;;;   Emacs: (put 'define-variant-type 'scheme-indent-function 4)
;;;   Edwin: (scheme-indent-method 'DEFINE-VARIANT-TYPE 4)

(declare (usual-integrations))

(define-syntax define-variant-type
  (syntax-rules (VARIANT)
    ((DEFINE-VARIANT-TYPE id type-descriptor-id predicate-id
         case-macro-id
       (VARIANT variant-id (variant-conser-id variant-field-id ...))
       ...)
     (BEGIN (DEFINE type-descriptor-id (MAKE-RECORD-TYPE (QUOTE id)
                                                         '()))
            (SET-RECORD-TYPE-UNPARSER-METHOD!
             type-descriptor-id
             (STANDARD-UNPARSER-METHOD (QUOTE id)
               (LAMBDA (RECORD PORT)
                 (case-macro-id RECORD
                   ((variant-id variant-field-id ...)
                    (WRITE-CHAR #\SPACE PORT)
                    (WRITE (QUOTE (variant-id)) PORT)
                    (BEGIN (WRITE-CHAR #\SPACE PORT)
                           (WRITE variant-field-id PORT))
                    ...)
                   ...))))
            (ADD-GENERIC-PROCEDURE-GENERATOR   ; Make variants pretty-
             RECORD-DESCRIPTION                ; print nicely.
             (LET ((TAG (RECORD-TYPE-DISPATCH-TAG type-descriptor-id)))
               (LAMBDA (GENERIC TAGS)
                 GENERIC                ;ignore
                 (AND (EQ? (CAR TAGS) TAG)
                      (LAMBDA (RECORD)
                        (case-macro-id RECORD
                          ((variant-id variant-field-id ...)
                           `((variant-field-id ,variant-field-id)
                             ...))
                          ...))))))
            (DEFINE predicate-id (RECORD-PREDICATE type-descriptor-id))
            (DEFINE-ENUMERATION VARIANT-ENUMERATION
              (variant-id ...))
            (DEFINE-VARIANT-CASE-MACRO case-macro-id predicate-id
              VARIANT-ENUMERATION
              (variant-id variant-field-id ...)
              ...)
            (DEFINE-VARIANT-CONSTRUCTORS type-descriptor-id
              VARIANT-ENUMERATION
              (variant-id (variant-conser-id variant-field-id ...))
              ...)))))

;;;; Variant Case Dispatcher Macros

(define-syntax define-variant-case-macro
  (rsc-macro-transformer
   (lambda (form closing-environment)
     (let ((case-macro-id (cadr form))
           (predicate-id (caddr form))
           (enumeration-id (cadddr form))
           (variants (cddddr form)))
       (capture-syntactic-environment
        (lambda (environment)
          `(,(close-syntax 'DEFINE-SYNTAX closing-environment)
               ,case-macro-id
             ,(close-syntax
               (make-variant-case-transformer case-macro-id
                                              predicate-id
                                              enumeration-id
                                              variants
                                              environment)
               closing-environment))))))))

(define (make-variant-case-transformer case-macro-id
                                       predicate-id enumeration-id
                                       variants
                                       environment)
  (capture-syntactic-environment
   (lambda (closing-environment)
     (define (close form) (close-syntax form closing-environment))
     (define (save form) `(,'UNQUOTE ,(syntax-quote (close form))))
     `(SC-MACRO-TRANSFORMER
       (LAMBDA (FORM ENVIRONMENT)
         (IF (NOT (SYNTAX-MATCH? '(DATUM + (DATUM + FORM))
                                 (CDR FORM)))
             (ILL-FORMED-SYNTAX FORM)
             (LET ((DATUM (CADR FORM))
                   (CLAUSES (CDDR FORM)))
               (CAPTURE-SYNTACTIC-ENVIRONMENT
                (LAMBDA (CLOSING-ENVIRONMENT)
                  (,'QUASIQUOTE
                   (,(save 'LET)
                       ((DATUM (,'UNQUOTE
                                (CLOSE-SYNTAX DATUM
                                              ENVIRONMENT))))
                     (,(save 'IF)
                         ((,'UNQUOTE
                           ,(syntax-quote (close-syntax predicate-id
                                                        environment)))
                          DATUM)
                       (,(save 'ENUM-CASE)
                           (,'UNQUOTE
                            ,(syntax-quote (close-syntax enumeration-id
                                                         environment)))
                           (,(save '%VARIANT-ENUMERAND) DATUM)
                         (,'UNQUOTE-SPLICING
                          (MAP (LAMBDA (CLAUSE)
                                 (GENERATE-CLAUSE
                                  CLAUSE ',variants
                                  ',case-macro-id
                                  ENVIRONMENT CLOSING-ENVIRONMENT
                                  ,(syntax-quote (close 'LET))
                                  ,(syntax-quote
                                    (close '%VARIANT-RECORD-REF))
                                  'DATUM))
                               CLAUSES)))
                       (,(save 'ERROR)
                        "Invalid datum in variant case:"
                        (,(save 'LIST)
                         (,(save 'QUOTE) ,case-macro-id)
                         DATUM
                         (,(save 'QUOTE) ...)))))))))))))))

;;; This is defined internally to the implementation of SYNTAX-RULES,
;;; but it is not exported.  It should be: it is necessary for macro-
;;; generating macros.

(define syntax-quote
  (let ((compiler->keyword
         (access compiler->keyword
                 (->environment '(RUNTIME SYNTACTIC-CLOSURES))))
        (output/constant
         (access output/constant
                 (->environment '(RUNTIME SYNTACTIC-CLOSURES)))))
    (lambda (datum)
      `(,(compiler->keyword
          (lambda (form environment history)
            environment history         ;ignore
            (output/constant (cadr form))))
        ,datum))))

(define (generate-clause clause variants keyword
                         environment closing-environment
                         let-keyword record-ref datum-variable)
  (if (and (identifier? (car clause))
           (identifier=? environment (car clause)
                         closing-environment 'ELSE))
      (cons (car clause)
            (map (lambda (body-form)
                   (close-syntax body-form environment))
                 (cdr clause)))
      (let ((lose (lambda ()
                    (error "Invalid variant type case clause:"
                           `(,keyword ... ,clause ...)))))
        (if (not (syntax-match? '((IDENTIFIER * IDENTIFIER) + FORM)
                                clause))
            (lose)
            (let ((variant-id (caar clause))
                  (field-variables (cdar clause)))
              (let ((body (map (lambda (subform)
                                 (make-syntactic-closure
                                     environment
                                     field-variables
                                   subform))
                               (cdr clause))))
                (cond ((find-matching-item variants
                         (lambda (variant)
                           (identifier=? environment variant-id
                                         closing-environment
                                         (car variant))))
                       => (lambda (probe)
                            (if (= (length field-variables)
                                   (length (cdr probe)))
                                (make-clause (car probe)
                                             let-keyword record-ref
                                             datum-variable
                                             field-variables body)
                                (lose))))
                      (else (lose)))))))))

(define (make-clause variant-id let-keyword record-ref
                     datum-variable field-variables body)
  `((,variant-id)
    (,let-keyword ,(do ((i 0 (+ i 1))
                        (variables field-variables (cdr variables))
                        (bindings '()
                                  (cons `(,(car variables)
                                          (,record-ref ,datum-variable
                                                       ,i))
                                        bindings)))
                       ((null? variables)
                        bindings))
      ,@body)))

;;;; Variant Constructors

(define-syntax define-variant-constructors
  (sc-macro-transformer
   (lambda (form environment)
     (let ((type-descriptor-id (close-syntax (cadr form) environment))
           (enumeration (close-syntax (caddr form) environment))
           (variants (cdddr form)))
       `(BEGIN ,@(map (lambda (variant)
                        (let ((variant-id (car variant))
                              (conser-id (caadr variant))
                              (field-ids (cdadr variant)))
                          `(DEFINE-VARIANT-CONSTRUCTOR
                             ,type-descriptor-id
                             (,(close-syntax conser-id environment)
                              ,@(map (lambda (id)
                                       (close-syntax id environment))
                                     field-ids))
                             (ENUM ,enumeration ,variant-id))))
                      variants))))))

(define-syntax define-variant-constructor
  (sc-macro-transformer
   (lambda (form environment)
     (let ((type-descriptor-id (close-syntax (cadr form)
                                             environment))
           (conser-id (close-syntax (caaddr form) environment))
           (field-ids (cdaddr form))
           (enumerand (close-syntax (cadddr form) environment))
           (tag (make-synthetic-identifier 'TAG)))
       `(DEFINE ,conser-id
          (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,type-descriptor-id)))
            (LAMBDA ,field-ids
              (LET ((RECORD (%MAKE-VARIANT-RECORD
                             ,tag
                             ,enumerand
                             ,(length field-ids))))
                ,@(do ((i 0 (+ i 1))
                       (ids field-ids (cdr ids))
                       (inits '()
                              (cons `(%VARIANT-RECORD-SET! RECORD
                                                           ,i
                                                           ,(car ids))
                                    inits)))
                      ((null? ids) inits))
                RECORD))))))))

;;;; Internal Representation of Variant Records

(define-integrable variant-enumerand-index 1)
(define-integrable variant-enumerand-overhead
                   (fix:+ variant-enumerand-index 1))

(define-integrable (%variant-enumerand object)
  (%record-ref object variant-enumerand-index))

(define-integrable (%make-variant-record tag enumerand size)
  (let ((record (%make-record (fix:+ size variant-enumerand-overhead)
                              #f)))
    (%record-set! record 0 tag)
    (%record-set! record 1 enumerand)
    record))

(define-integrable (%variant-record-ref record index)
  (%record-ref record (fix:+ index variant-enumerand-overhead)))

(define-integrable (%variant-record-set! record index value)
  (%record-set! record
                (fix:+ index variant-enumerand-overhead)
                value))