;;; dd2-checked.ss

;;; Time-stamp: <1999-02-08 15:29:54 ehilsdal>
;;; (time-stamp generated by emacs:  Type M-x time-stamp anywhere to update)

;;; This is an r5rs-compliant datatype system. 

;;; ------------------------------
;;; System notes

;;;  * Old MzSchemes are not r5rs-compliant: they do not provide the
;;;  r4 or r5rs-like macro systems except upon request.  If you are
;;;  running such a Scheme, execute `(require-library "synrule.ss")'
;;;  before executing the code in this file.  

;;;  * Old MzSchemes's r5rs-like macro systems do not provide
;;;  letrec-syntax.  If you are using such a Scheme, uncomment the
;;;  second (stub) definition of dd:check:not-member.  You will lose
;;;  some robustness and error checking, but correct uses of the
;;;  `define-datatype' and `cases' forms will still work.

;;;  * It is possible to get better formatted error messages under
;;;  Chez Scheme.  If you are running Chez, uncomment the second
;;;  dd:syntax-error definition.

;;; ------------------------------
;;; User interface

;;;(define-datatype Type-name Predicate-name
;;;  (Variant-name (Field-name Predicate-exp) ...) ...)
;;;                    -> defines Variant-name ..., Predicate-name, Type-name
;;;(cases Type-name Exp Clause ...)

(define-syntax cases
  (syntax-rules ()
    ((_ Type-name Exp Clause ...)
     (dd:check-cases (cases Type-name Exp Clause ...) Type-name (Clause ...) ()
       (let ((v Exp))
	 (if (Type-name '(isa-cookie v))
	     (Type-name '(cases-cookie v Clause ...))
	     (error 'cases "not a ~a variant: ~s" 'Type-name v)))))))

(define-syntax define-datatype
  (syntax-rules ()
    ((_ . Rest)
     (dd:check-define-datatype (define-datatype . Rest) Rest
       (dd:define-datatype . Rest)))))

;;; ------------------------------
;;; datatype definition

(define-syntax dd:check-define-datatype
  (syntax-rules ()
    ((_ Exp (Type-name) K)
     (dd:syntax-error Exp "No predicate-name in"))
    ((_ Exp (Type-name Pred-name) K)
     (dd:syntax-error Exp "No variants defined in"))
    ((_ Exp (Type-name Pred-name (Variant-name (Field-name Pred?) ...) ...) K)
     (dd:check:all-identifiers Exp (Type-name Pred-name Variant-name ...)
       "is not an identifier in"
       (dd:check:no-duplicates Exp (Type-name Pred-name Variant-name ...)
	 "is duplicated in"
	 K)))
    ((_ Exp (Whatever ...) K)
     (dd:syntax-error Exp "Bad define-datatype form"))))

(define-syntax dd:define-datatype
  (syntax-rules ()
    ((_ Type-name Pred-name (Variant-name (Field-name Pred?) ...) ...)
     (begin
       (define-syntax Type-name
	 (syntax-rules (isa-cookie cases-cookie
			 check-coverage-cookie check-clause-cookie
			 Variant-name ... else quote)
	   ((_ '(isa-cookie Var))
	    (and (procedure? Var) (eq? (car (Var)) 'Type-name)))

	   ((_ '(check-coverage-cookie Exp Used-variants K))
	    (dd:check:equal-lengths Exp Used-variants (Variant-name ...)
	      "Non-exhaustive cases form"
	      K))
	   ((_ '(check-clause-cookie Clause Variant-name Formals
		  Used-variants K))
	    (dd:check:equal-lengths Clause Formals (Field-name ...)
	      "Wrong number of formals in cases clause"
	      (dd:check:not-member Clause Variant-name Used-variants
		"is handled in duplicate cases variant clause"
		K)))
	   ...
	   ((_ '(check-clause-cookie Clause NonVariant-name Formals
		  Used-variants K))
	    (dd:syntax-error Clause "Bad variant name in cases clause"))

	   ((_ '(cases-cookie Var (else e0 . exps)))
	    (begin e0 . exps))
	   ((_ '(cases-cookie Var (Variant-name Formals e0 . exps)))
	    (apply (lambda Formals e0 . exps) (cddr (Var))))
	   ...
	   ((_ '(cases-cookie Var (Variant-name Formals e0 . exps) . Clauses))
	    (if (eq? (cadr (Var)) 'Variant-name)
		(apply (lambda Formals e0 . exps) (cddr (Var)))
		(Type-name '(cases-cookie Var . Clauses))))
	   ...))
       (define Pred-name
	 (lambda (x)
	   (Type-name '(isa-cookie x))))
       (define Variant-name
	 (dd:constructor-exp Type-name Variant-name
	   (Field-name ...) (Pred? ...)))
       ...))))

;;; ------------------------------
;;; construction

(define-syntax dd:constructor-exp
  (syntax-rules ()
    ((_ Type-name Variant-name (Field-name ...) (Pred ...))
     (dd:generate-temporaries
       (dd:constructor-exp-help
	 Type-name Variant-name (Field-name ...) (Pred ...))
       ()
       (Field-name ...)))))

(define-syntax dd:constructor-exp-help
  (syntax-rules ()
    ((_ (Temp ...) Type-name Variant-name (Field-name ...) (Pred ...))
     (lambda (Temp ...)
       (unless (Pred Temp)
	 (error 'Variant-name "Bad ~a field: (~s ~s) => #f"
	   'Field-name 'Pred Temp))
       ...
       (let ((record (list 'Type-name 'Variant-name Temp ...)))
	 (lambda () record))))))

(define-syntax dd:generate-temporaries
  (syntax-rules ()
    ((_ (Khead . KTail) Out ())
     (Khead Out . KTail))
    ((_ K Out (In0 . In))
     (dd:generate-temporaries K (temp . Out) In))))

;;; ------------------------------
;;; case

(define-syntax dd:check-cases
  (syntax-rules (else)
    ;; Source Type-name Clauses Variants-so-far K
    ((_ Src Type-name ((else Exp0 Exp ...)) Used-variants K)
     K)
    ((_ Src Type-name () Used-variants K)
     (Type-name '(check-coverage-cookie Src Used-variants K)))
    ((_ Src Type-name ((Variant-name (Formal ...) Exp0 Exp ...) Clause ...)
       Used-variants K)
     (dd:check:all-identifiers (Variant-name (Formal ...) Exp0 Exp ...)
       (Formal ...)
       "is not an identifier in the formals of cases clause"
       (dd:check:no-duplicates (Variant-name (Formal ...) Exp0 Exp ...)
	 (Formal ...)
	 "is duplicated in the formals of cases clause"
	 (Type-name
	   '(check-clause-cookie
	      (Variant-name (Formal ...) Exp0 Exp ...)
	      Variant-name (Formal ...) Used-variants
	      (dd:check-cases Src Type-name (Clause ...)
		(Variant-name . Used-variants)
		K))))))
    ((_ Src Type-name (Bad-clause Clause ...) Used-variants K)
     (dd:syntax-error Bad-clause "Malformed cases clause:"))))

;;; ------------------------------
;;; checker helpers

(define-syntax dd:check:equal-lengths
  (syntax-rules ()
    ;; Source thing1 thing2 message continuation
    ((_ Src () () Message K)
     K)
    ((_ Src (v w ...) (x y ...) Message K)
     (dd:check:equal-lengths Src (w ...) (y ...) Message K))
    ((_ Src Else0 Else1 Message K)
     (dd:syntax-error Src Message))))

(define-syntax dd:check:all-identifiers
  (syntax-rules ()
    ;; Source list message continuation
    ((_ Src () Message K)
     K)

    ((_ Src (() Rest ...) Message K)
     (dd:syntax-error Src () Message))
    ((_ Src ((WhateverHead . WhateverTail) Rest ...) Message K)
     (dd:syntax-error Src (WhateverHead . WhateverTail) Message))
    ((_ Src (#(Whatever ...) Rest ...) Message K)
     (dd:syntax-error Src #(Whatever ...) Message))

    ((_ Src (Id Rest ...) Message K)
     (dd:check:all-identifiers Src (Rest ...) Message K))))

(define-syntax dd:check:not-member	; correct version
  (syntax-rules ()
    ;; source item list message continuation
    ((_ Src Item List Message K)
     (letrec-syntax ((mem (syntax-rules (Item)
			    ;; source list Message K
			    ((__ _Src () _M _K)
			     _K)
			    ((__ _Src (Item . Rest) _M _K)
			     (dd:syntax-error _Src Item _M))
			    ((__ _Src (NonItem . Rest) _M _K)
			     (mem _Src Rest _M _K)))))
       (mem Src List Message K)))))

;;(define-syntax dd:check:not-member	; use if letrec-syntax is problematic
;;  (syntax-rules ()
;;    ;; source item list message continuation
;;    ((_ Src Item List Message K)
;;     K)))

(define-syntax dd:check:no-duplicates
  (syntax-rules ()
    ;; source list message continuation
    ((_ Src () Message K)
     K)
    ((_ Src (Id0 Rest ...) Message K)
     (dd:check:not-member Src Id0 (Rest ...) Message 
       (dd:check:no-duplicates Src (Rest ...) Message
	 K)))))

;;; ------------------------------
;;; Error stuff

(define-syntax serror:
  (syntax-rules ()))

(define-syntax dd:syntax-error		; portable version
  (syntax-rules ()
    ((_ Src Message-thing ...)
     (serror: Message-thing ... Src))))

;;;(define-syntax dd:syntax-error		; version for Chez
;;;  (lambda (x)
;;;    (syntax-case x ()
;;;      ((_ Src Message-thing ...)
;;;       (apply error #f (string-append
;;;			 (apply string-append
;;;			   (map (lambda (x) "~a ")
;;;			     (syntax (Message-thing ...))))
;;;			 "~n~s")
;;;	 (map syntax-object->datum
;;;	   (syntax (Message-thing ... Src))))))))

;;; ------------------------------
;;; general helpers

(define always?
  (lambda (x) #t))

(define list-of
  (lambda (pred . l)
    (let ((all-preds (cons pred l)))
      (lambda (obj)
        (let loop ((obj obj) (preds '()))
          (or 
            ;; if list is empty, preds should be, too
            (and (null? obj) (null? preds))
            (if (null? preds)
		;; if preds is empty, but list isn't, then recycle
		(loop obj all-preds)
		;; otherwise check and element and recur.
		(and (pair? obj)
		     ((car preds) (car obj))
		     (loop (cdr obj) (cdr preds))))))))))