;;; datatype-chez.ss

;;; Time-stamp: <1999-02-12 20:33:18 ehilsdal>
;;; (time-stamp generated by emacs:  Type M-x time-stamp anywhere to update)

;;; This is a Chez-specific (version 6.0) implementation of an r5rs-compliant
;;; datatype system. 

;;; ------------------------------
;;; 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 ...)

(eval-when (compile)
  (generate-inspector-information #f)
  (optimize-level 2))

(module ((define-datatype
	   check-define-datatype
	   do-define-datatype
	   define-constructor
	   syn-err)
	 (cases
	   check-coverage
	   check-clause
	   syn-err))

(define-syntax define-datatype
  (syntax-rules ()
    ((_ . Rest)
     (check-define-datatype (define-datatype . Rest) Rest
       (do-define-datatype . Rest)))))

(define-syntax cases
  (syntax-rules ()
    ((_ Type-name Exp Clause ...)
     (Type-name
       'pre-cases-cookie
       (syn-err (cases Type-name Exp Clause ...)
	 "undefined datatype ~s in" Type-name)
       '((cases Type-name Exp Clause ...) Exp Clause ...)))))

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

;;; this uses an extremely annoying temporary macro to allow this to
;;; be used both at top-level and within stuff.

(define-syntax do-define-datatype
  (syntax-rules ()
    ((_ Type-name Pred-name (Variant-name (Field-name Pred?) ...) ...)
     (begin
       (module ((Type-name dd-rec-variant dd-rec-contents)
		(annoying-invisible-identifier make-dd-rec dd-rec?))
	 (define-record dd-rec ((immutable variant) (immutable contents)) ()
	   ((print-method
	      (let ((name (format "#<~s>" 'Type-name)))
		(lambda (r p wr) (display name p))))))
	 (define-syntax annoying-invisible-identifier
	   (syntax-rules (make check)
	     ((_ make) make-dd-rec)
	     ((_ check) dd-rec?)))
	 (define-syntax Type-name
	   (syntax-rules ( quote pre-cases-cookie cases-cookie
			   Variant-name ... else )
	     ((_ 'pre-cases-cookie Fail-exp '(Src Exp . Clauses))
	      (let ((v Exp))
		(unless (Pred-name v)
		  (error 'cases "~s is not a ~a variant" v 'Type-name))
		(let ((v-sym (dd-rec-variant v))
		      (v-contents (dd-rec-contents v)))
		  (Type-name 'cases-cookie
		    Src v-sym v-contents () . Clauses))))

	     ((_ 'cases-cookie Src Var Contents Used (else e0 . exps))
	      (begin e0 . exps))
	     ((_ 'cases-cookie Src Var Contents Used
		(Variant-name (Fml (... ...)) e0 . exps))
	      (check-clause Src (Fml (... ...)) (Field-name ...)
		Variant-name Used
		(check-coverage Src (Variant-name . Used) (Variant-name ...)
		  (apply (lambda (Fml (... ...)) e0 . exps) Contents))))
	     ...
	     ((_ 'cases-cookie Src Var Contents Used
		(Variant-name (Fml (... ...)) e0 . exps) . Clauses)
	      (check-clause Src (Fml (... ...)) (Field-name ...)
		Variant-name Used
		(if (eq? Var 'Variant-name)
		    (apply (lambda (Fml (... ...)) e0 . exps) Contents)
		    (Type-name 'cases-cookie Src Var Contents
		      (Variant-name . Used) . Clauses))))
	     ...
	     ((_ 'cases-cookie Src Var Contents Used
		(Unknown-variant (Fml (... ...)) e0 . exps) . Clauses)
	      (syn-err Src "the ~s datatype has no ~s variant"
		Type-name Unknown-variant))
	     ((_ 'cases-cookie Src Var Contents Used Bad-clause . Clauses)
	      (syn-err Src "bad clause~n~s~nin" Bad-clause)))))
       (define Pred-name
	 (lambda (x)
	   ((annoying-invisible-identifier check) x)))
       (define-constructor Variant-name (annoying-invisible-identifier make)
	 (Field-name ...) (Pred? ...))
       ...))))

(define-syntax define-constructor
  (lambda (x)
    (syntax-case x ()
      ((_ Variant-name Maker (Field-name ...) (Pred ...))
       (with-syntax (((Temp ...) (generate-temporaries #'(Field-name ...))))
	 #'(define Variant-name
	     (lambda (Temp ...)
	       (unless (Pred Temp)
		 (error 'Variant-name "bad ~a field: (~s ~s) => #f"
		   'Field-name 'Pred Temp))
	       ...
	       (let ((contents (list Temp ...)))
		 (Maker 'Variant-name contents)))))))))

;;; ------------------------------
;;; checks

(define-syntax check-clause
  (let* ()
    (define-syntax aif
      (syntax-rules ()
	((_ ?id ?t ?c ?a)
	 (let ((?id ?t))
	   (if ?id (with-syntax ((?id ?id)) ?c) ?a)))))
    (define find-non-id
      (lambda (ls)
	(ormap (lambda (x) (and (not (identifier? x)) x)) ls)))
    (define id-member
      (lambda (id ids)
	(and (not (null? ids))
	     (or (and (free-identifier=? id (car ids)) id)
		 (id-member id (cdr ids))))))
    (define find-dups
      (lambda (ls)
	(and (not (null? ls))
	     (or (id-member (car ls) (cdr ls))
		 (find-dups (cdr ls))))))
    (lambda (x)
      (syntax-case x ()
	((_ Src (Formal ...) (Field ...) Variant-name (Used ...) K)
	 (aif nonid (find-non-id #'(Formal ...))
	   #'(syn-err Src "bad formal ~s in ~a clause"
	       nonid Variant-name)
	   (aif dup (find-dups #'(Formal ...))
	     #'(syn-err Src "duplicate formal ~s in ~a clause"
		 dup Variant-name)
	     (if (not (= (length #'(Formal ...)) (length #'(Field ...))))
		 #'(syn-err Src "wrong number of formals in ~a clause"
		     Variant-name)
		 (if (id-member #'Variant-name #'(Used ...))
		     #'(syn-err Src "duplicate clause for ~a variant"
			 Variant-name)
		     #'K)))))
	((_ Src Wacky-formals (Field ...) Variant-name (Used ...) K)
	 #'(syn-err Src "bad formals ~s in ~a clause"
	     Wacky-formals Variant-name))))))

(define-syntax check-coverage
  (let* ()
    (define id-member
      (lambda (id ids)
	(and (not (null? ids))
	     (or (and (free-identifier=? id (car ids)) id)
		 (id-member id (cdr ids))))))
    (define difference
      (lambda (a b)
	(if (null? a) '()
	    (if (id-member (car a) b)
		(difference (cdr a) b)
		(cons (car a) (difference (cdr a) b))))))
    (lambda (x)
      (syntax-case x ()
	((_ Src (Used ...) (Required ...) K)
	 (let ((diff (difference #'(Required ...) #'(Used ...))))
	   (if (not (null? diff))
	       (with-syntax ((diff diff))
		 #'(syn-err Src "missing clauses for some variants: ~s" diff))
	       #'K)))))))

(define-syntax check-define-datatype
  (let* ()
    (define-syntax aif
      (syntax-rules ()
	((_ ?id ?t ?c ?a)
	 (let ((?id ?t))
	   (if ?id (with-syntax ((?id ?id)) ?c) ?a)))))
    (define find-non-id
      (lambda (ls)
	(ormap (lambda (x) (and (not (identifier? x)) x)) ls)))
    (define find-dups
      (lambda (ls)
	(and (not (null? ls))
	     (or (let mem ((x (car ls)) (ls (cdr ls)))
		   (and (not (null? ls))
			(or (and (bound-identifier=? x (car ls)) x)
			    (mem x (cdr ls)))))
		 (find-dups (cdr ls))))))
    (lambda (x)
      (syntax-case x ()
	((_ Exp (Type-name) K)
	 #'(syn-err Exp "no predicate name in"))
	((_ Exp (Type-name Pred-name) K)
	 #'(syn-err Exp "no variants defined in"))
	((_ Exp (Type-name Pred-name (Variant-name (Field-name Pred?) ...) ...)
	   K)
	 (aif nonid (find-non-id #'(Type-name Pred-name Variant-name ...))
	   #'(syn-err Exp "~s is not an identifier in" nonid)
	   (aif dup (find-dups #'(Type-name Pred-name Variant-name ...))
	     #'(syn-err Exp "~s is duplicated in" dup)
	     #'K)))
	((_ Exp Whatever K)
	 #'(syn-err Exp "invalid syntax"))))))

;;; ------------------------------
;;; errors

(define-syntax syn-err
  (lambda (x)
    (syntax-case x ()
      ((_ Src Format-string Arg ...)
       (let ((fs (syntax-object->datum #'Format-string))
	     (args (map syntax-object->datum #'(Arg ... Src))))
	 (apply error #f (string-append fs "~n  ~a") args))))))

)

(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))))))))))