;;; -*- mode: scheme; scheme48-package: variant-types -*-

;;;; Variant Record Types

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain (except where explicitly noted).  All warranties are
;;; disclaimed.

;;; Evaluate this in the config package:
;;;
;;; (define-structure variant-types
;;;     (export (define-variant-type :syntax))
;;;   (open scheme
;;;         record-types
;;;         records
;;;         ;; not ENUMERATED -- see definition of DEFINE-ENUMERATION &
;;;         ;; ENUM in the code
;;;         enum-case
;;;         code-quote
;;;         destructuring
;;;         signals
;;;         util
;;;         )
;;;   (for-syntax (open scheme
;;;                     destructuring
;;;                     names
;;;                     ))
;;;   (files variant-type))
;;;
;;; 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.
;;;
;;; This code surely has bugs, particularly in its hygienic renaming.
;;; Please report them by mail 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).

;; (put 'define-variant-type 'scheme-indent-function 4)

(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)
                                      '()   ; What to do about fields?
                                      ))
            (DEFINE-RECORD-DISCLOSER type-descriptor-id
              (LAMBDA (RECORD)
                (CONS (QUOTE id)
                      (case-macro-id RECORD
                        ((variant-id variant-field-id ...)
                         (list (QUOTE (variant-id))
                               variant-field-id
                               ...))
                        ...))))
            (DEFINE (predicate-id X)
              (AND (RECORD? X)
                   (EQ? (RECORD-REF X 0)
                        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-CONSTRUCTOR type-descriptor-id
              (variant-conser-id variant-field-id ...)
              (ENUM VARIANT-ENUMERATION variant-id))
            ...))))

;;;; Integer Enumerations

;;; Copied from rts/defenum.scm; copyright (C) 1993-2005 Richard Kelsey
;;; and Jonathan Rees.  See the Scheme48 source for the licence terms.
;;; There is a slight modification here, in the local CONC procedure,
;;; so that it works on generated names, as we need.

(define-syntax define-enumeration
  (lambda (form rename compare)
    (let ((name (cadr form))
          (components (list->vector (caddr form)))
          (conc (lambda things
                  (string->symbol (apply string-append
                                         (map (lambda (thing)
                                                (if (name? thing)
                                                    (symbol->string
                                                     (name->symbol thing))
                                                    thing))
                                              things)))))
          (%define (rename 'define))
          (%define-syntax (rename 'define-syntax))
          (%begin (rename 'begin))
          (%quote (rename 'quote)))
      (let ((e-name (conc name '- 'enumeration))
            (count (vector-length components)))
        `(,%begin (,%define-syntax ,name
                    (cons (let ((components ',components))
                            (lambda (e r c)
                              (let ((key (cadr e)))
                                (cond ((c key 'components)
                                       (r ',e-name))
                                      ((c key 'enum)
                                       (let ((which (caddr e)))
                                         (let loop ((i 0)) ;vector-posq
                                           (if (< i ,count)
                                               (if (c which (vector-ref components i))
                                                   i
                                                   (loop (+ i 1)))
                                               ;; (syntax-error "unknown enumerand name"
                                               ;;               `(,(cadr e) ,(car e) ,(caddr e)))
                                               e))))
                                      (else e)))))
                          '(,e-name)))  ;Auxiliary binding
                  (,%define ,e-name ',components)
                  (,%define ,(conc name '- 'count) ,count)))))
  (begin define define-syntax quote))

;;; Define ENUM, too, so that we need not open ENUMERATED at all.

(define-syntax enum
  (cons (lambda (e r c) `(,(cadr e) enum ,(caddr e)))
        '()))

;;;; Variant Case Dispatcher Macros

;;; This macro is very hard to follow because of its nesting.  I do
;;; apologize.

;;; I am not sure whether the auxiliary name lists are correct.

(define-syntax define-variant-case-macro
  (lambda (form rename compare)
    (destructure (( (keyword case-macro-id predicate-id enumeration-id
                      . variants)
                    form))

      (define datum-rename
              `(,(rename 'RENAME) (,(rename 'QUOTE) DATUM)))

      (define (code-quote exp) `(,(rename 'CODE-QUOTE) ,exp))

      (define (code-unquote exp)
        `(,(rename 'UNQUOTE) ,(code-quote exp)))

      `(,(rename 'DEFINE-SYNTAX) ,case-macro-id
         (,(rename 'LAMBDA) (,(rename 'FORM)
                             ,(rename 'RENAME)
                             ,(rename 'COMPARE))
           (,(rename 'DESTRUCTURE)
               (( (,(rename 'KEYWORD) ,(rename 'DATUM)
                    . ,(rename 'CLAUSES))
                  ,(rename 'FORM)))
             (,(rename 'QUASIQUOTE)
               (,(code-unquote (rename 'LET))
                   (((,(rename 'UNQUOTE) ,datum-rename)
                     (,(rename 'UNQUOTE) ,(rename 'DATUM))))
                 (,(rename 'IF)
                     (,(code-unquote predicate-id)
                      (,(rename 'UNQUOTE) ,datum-rename))
                   (,(code-unquote (rename 'ENUM-CASE))
                       ,(code-unquote enumeration-id)
                       (,(code-unquote (rename 'RECORD-REF))
                        (,(rename 'UNQUOTE) ,datum-rename)
                        1)
                     (,(rename 'UNQUOTE-SPLICING)
                      (,(rename 'MAP)
                       (,(rename 'LAMBDA) (,(rename 'CLAUSE))
                         (,(rename 'GENERATE-CLAUSE)
                          ,(rename 'CLAUSE)
                          ,(code-quote variants)
                          (,(rename 'QUOTE) ,case-macro-id)
                          ,(rename 'RENAME)
                          ,(rename 'COMPARE)
                          ,(code-quote (rename 'LET))
                          ,(code-quote (rename 'RECORD-REF))
                          ,datum-rename))
                       ,(rename 'CLAUSES))))
                   (,(code-unquote (rename 'ERROR))
                    "invalid datum in variant case"
                    (,(rename 'UNQUOTE) ,datum-rename)
                    (,(code-unquote (rename 'QUOTE))
                     ,case-macro-id)))))))
         ,(map code-quote               ; Auxiliary names
               `(RECORD-REF LET ENUM-CASE ,enumeration-id
                            ,@(map car variants)))
         )))
  (QUOTE CODE-QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING DEFINE-SYNTAX
   LAMBDA DESTRUCTURE QUASIQUOTE LET ENUM-CASE RECORD-REF MAP
   GENERATE-CLAUSE))

(define (generate-clause clause variants keyword rename compare
                         let-keyword record-ref datum-id)
  (if (compare (car clause) (rename 'ELSE))
      clause
      (let ((lose (lambda ()
                    (error "invalid variant type case clause"
                           keyword
                           clause))))
        (destructure (( ((variant-id . field-vars) . body)
                        clause))
          (cond ((let loop ((variants variants))
                   (and (pair? variants)
                        (or (and (compare (caar variants)
                                          variant-id)
                                 (car variants))
                            (loop (cdr variants)))))
                 => (lambda (probe)
                      (if (= (length field-vars)
                             (length (cdr probe)))
                          `((,(car probe))
                            (,let-keyword
                                ,(do ((i 2 (+ i 1))
                                      (vars field-vars (cdr vars))
                                      (bindings '()
                                                (cons `(,(car vars)
                                                        (,record-ref
                                                         ,datum-id
                                                         ,i))
                                                      bindings)))
                                     ((null? vars) bindings))
                              ,@body))
                          (lose))))
                (else (lose)))))))

;;;; Variant Constructors

(define-syntax define-variant-constructor
  (lambda (form rename compare)
    (destructure (( (keyword type-descriptor-id
                      (conser-id . field-ids)
                      enumerand)
                    form))
      `(,(rename 'DEFINE) (,conser-id ,@field-ids)
         (,(rename 'LET) ((,(rename 'RECORD)
                           (,(rename 'MAKE-RECORD)
                            ,(+ 2 (length field-ids))
                            (,(rename 'UNSPECIFIC)))))
           (,(rename 'RECORD-SET!) ,(rename 'RECORD) 0
                                   ,type-descriptor-id)
           (,(rename 'RECORD-SET!) ,(rename 'RECORD) 1 ,enumerand)
           ,@(do ((i 2 (+ i 1))
                  (ids field-ids (cdr ids))
                  (commands '()
                            (cons `(,(rename 'RECORD-SET!)
                                    ,(rename 'RECORD)
                                    ,i
                                    ,(car ids))
                                  commands)))
                 ((null? ids) commands))
           ,(rename 'RECORD))))))