;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; recon.scm: TYPE RECONSTRUCTOR FOR Scheme/R
;;;
;;; To run this code, first load Scheme+, then this file.
;;;
;;; Evaluate
;;;
;;;    (recon <sexp>)
;;;
;;; to type-reconstruct the Scheme/R expression <sexp>
;;;
;;;


;;;----------------------------------------------------------------------------
;;; Magic for handling unit.  This should really be in a separate file, or
;;; be part of Scheme+.

(define-structure (unit-obj (print-procedure 
			     (lambda (state struct) 
			       (unparse-string state "#u")))))

;; THE-UNIT is the unique instance of the UNIT-OBJ structure
(define the-unit (make-unit-obj))

(define (unit? obj) (eq? obj the-unit))

;;; Changing parser to handle #u
(define parse-object/unit
  (let ((discard-char (access discard-char 
			      (->environment (find-package '(runtime parser))))))
    (lambda ()
      (discard-char)
      the-unit)))

(parser-table/set-entry! system-global-parser-table
			 '("#u" "#U")
			 parse-object/unit)

;;; Constructors for handling UNIT

(define unit->sexp  
  (make-constructor
   (lambda () #u)
   (lambda (sexp succ fail)
     (if (unit? sexp)
	 (succ)
	 (fail)))))

(define a-unit unit->sexp)


;;;----------------------------------------------------------------------------
;;; SYM-SEXP is a synonym for SYMBOL->SEXP (and should replace it in 
;;; future versions of Scheme+)

(define sym->sexp (make-sexp-constructor 'sym symbol?))

;;;----------------------------------------------------------------------------
;;; CELLS in Scheme
(define cell-tag (list '*cell*))
(define (cell val) (list cell-tag val))
(define (cell? x) (and (list? x) (= (length x) 2) (eq? (car x) cell-tag)))
(define (^ x) (if (cell? x) (cadr x) (error "^: not a cell " x)))
(define (:= x y) (if (cell? x) (begin (set-car! (cdr x) y) #u)
		     (error "^: not a cell " x)))


;;;----------------------------------------------------------------------------
;;; DATATYPES

;;; Expressions 

(define-datatype exp                          ; E ::= 
  (unit->exp)                                 ;       Unit
  (boolean->exp bool)                         ;     | Bool
  (integer->exp int)                          ;     | Int
  (string->exp string)                        ;     | String
  (symbol->exp sym)                           ;     | (symbol Sym)
  (variable->exp sym)                         ;     | I
  (lambda->exp (listof sym) exp)              ;     | (lambda (I*) E)
  (call->exp exp (listof exp))                ;     | (E0 E*)
  (if->exp exp exp exp)                       ;     | (if E1 E2 E3)
  (primop->exp primop (listof exp))	      ;     | (primop O E*)
  (let->exp (listof definition) exp)          ;     | (let ((I E)*) E0)
  (letrec->exp (listof definition) exp)       ;     | (letrec ((I E)*) E0)
  (set!->exp sym exp)			      ;     | (set! I E)
  (begin->exp exp exp)			      ;     | (begin E E)
  ;; **MODULES**
  (module->exp (listof definition))           ;     | (module (define I E)*)
  (with->exp (listof sym) exp exp)            ;     | (with (I*) E1 E2)
  ;; **MODULES**
  )

(define-datatype definition		      ; (I E)
  (make-definition sym exp))

(define (definition-name d)
  (match d
    ((make-definition name value) name)))

(define (definition-value d)
  (match d
    ((make-definition name value) value)))

;;; Types

(define-datatype type
  (tvariable->type tvariable)                 ; type variable
  (base->type sym)                            ; (unit, bool, int, string, symbol)
  (compound->type sym (listof type))          ; ->, list-of, etc.
  (unknown->type)                             ; placeholder for unconstrained tvars
  ;; **MODULES**
  (moduleof->type (listof sym) (listof type)) ; (moduleof (val I T)*)
  ;; **MODULES**
  )

(define unit-type    (base->type 'unit))
(define boolean-type (base->type 'bool))
(define integer-type (base->type 'int))
(define string-type  (base->type 'string))
(define symbol-type  (base->type 'sym))


(define same-constructor? eq?)

;; **MODULES**
(define (same-field-names? names1 names2)
  (if (null? names1)
      (null? names2)
      (if (null? names2)
	  #f
	  (and (eq? (car names1) (car names2))
	       (same-field-names? (cdr names1) (cdr names2))))))
;; **MODULES**

(define (make-arrow-type arg-types body-type)
  (compound->type arrow-constructor
		  (cons body-type arg-types)))

(define arrow-constructor '->)

(define same-name? eq?)

;;; Type schemas

(define-datatype tvar-or-schema
  (tvar->tvar-or-schema tvariable)
  (schema->tvar-or-schema schema))

(define-datatype schema
  (make-schema (listof tvariable) type))

(define (schema-generics s)
  (match s
    ((make-schema generics typ) generics)))

(define (schema-type s)
  (match s
    ((make-schema generics typ) typ)))


;;;----------------------------------------------------------------------------
;;; TYPE RECONSTRUCTION

(define (reconstruct exp tenv)
  (match exp
    ((unit->exp)                unit-type)
    ((boolean->exp _)           boolean-type)
    ((integer->exp _)           integer-type)
    ((string->exp _)            string-type)
    ((symbol->exp _)            symbol-type)
    ((variable->exp var)        (reconstruct-variable var tenv))
    ((if->exp test con alt)     (reconstruct-if test con alt tenv))
    ((primop->exp primop args)  (reconstruct-primop primop args tenv))
    ((lambda->exp formals body) (reconstruct-lambda formals body tenv))
    ((call->exp op args)        (reconstruct-call op args tenv))
    ((let->exp defs body)       (reconstruct-let defs body tenv))
    ((letrec->exp defs body)    (reconstruct-letrec defs body tenv))
    ((set!->exp id exp)         (reconstruct-set! id exp tenv))
    ((begin->exp exp1 exp2)     (reconstruct-begin exp1 exp2 tenv))
    ;; **MODULES**
    ((module->exp defs)         (reconstruct-module defs tenv))        ; ***
    ((with->exp vars mod body)  (reconstruct-with vars mod body tenv)) ; ***
    ;; **MODULES**
    ))

(define (reconstruct-variable var tenv)
  (let ((tvar-or-schema (tlookup tenv var)))
    (match tvar-or-schema
      ((tvar->tvar-or-schema tvar)
       (tvariable->type tvar))
      ((schema->tvar-or-schema schema)
       (instantiate-schema schema)))))

(define (reconstruct-if test con alt tenv)
  (begin (unify! (reconstruct test tenv)
		 boolean-type)
	 (let ((con-type (reconstruct con tenv))
	       (alt-type (reconstruct alt tenv)))
	   (begin (unify! con-type alt-type)
		  con-type))))

(define (reconstruct-lambda vars body tenv)
  (let ((new-tvars (map new-tvariable vars)))
    (make-arrow-type 
     (map tvariable->type new-tvars)
     (reconstruct body
		  (extend-by-tvariables tenv vars new-tvars)))))

(define (reconstruct-call op args tenv)
  (let ((arg-types (map (lambda (arg) (reconstruct arg tenv))
			args))
	(result-type (tvariable->type (new-tvariable 'result))))
    (begin (unify! (reconstruct op tenv)
		   (make-arrow-type arg-types result-type))
	   result-type)))

(define (reconstruct-primop op args tenv)
  (let ((arg-types (map (lambda (arg) (reconstruct arg tenv))
			args))
	(result-type (tvariable->type (new-tvariable 'result))))
    ;; Get the type of the operator from the standard type env:
    (begin (unify! (reconstruct-variable op standard-type-environment)
		   (make-arrow-type arg-types result-type))
	   result-type)))

(define (reconstruct-let defs body tenv)
  (reconstruct body
	       (extend-by-schemas
		tenv
		(map definition-name defs)
		(map (lambda (def)
		       (compute-schema 
			(reconstruct (definition-value def) tenv)
			tenv))
		     defs))))

(define (reconstruct-letrec defs body tenv)
  (let ((names (map definition-name defs)))
    (let ((tvars (map new-tvariable names)))
      (let ((dummy-tenv (extend-by-tvariables tenv names tvars)))
	(let ((types (map (lambda (def)
			    (reconstruct (definition-value def) dummy-tenv))
			  defs)))
	  (begin (for-each-2 unify!
			     (map tvariable->type tvars)
			     types)
		 (reconstruct body
			      (extend-by-schemas
			       tenv
			       names
			       (map (lambda (type)
				      (compute-schema type tenv))
				    types)))))))))

(define (for-each-2 proc lst1 lst2)
  (if (null? lst1)
      #u
      (begin
	(proc (car lst1) (car lst2))
	(for-each-2 proc (cdr lst1) (cdr lst2)))))

;;; Note: the use of UNIFY!-LIST rather than FOR-EACH-2 fails to 
;;; correctly type (or find a type error in) the following example:
;;; (recon '(letrec ((a (lambda () 3))
;;;                  (b (if (a) 1 2)))
;;;              4))


(define (reconstruct-set! id exp tenv)
  (begin (unify! (reconstruct-variable id tenv)
		 (reconstruct exp tenv))
	 unit-type))

(define (reconstruct-begin exp1 exp2 tenv)
  ;; Be sure to check type-safety of 1st expression:
  (begin (reconstruct exp1 tenv)
	 (reconstruct exp2 tenv)))




;;;----------------------------------------------------------------------------
;;; TYPE SCHEMAS

(define (compute-schema type tenv)	;Function GEN from handout
  (make-schema (generic-tvariables type tenv)
	       type))

; NOTE: generic-tvariables looks not only at tvariables in the
; given type, but also at tvariables in the leaves of 

; the fully unwound version of the given type.  This interacts with 
; a similar unwinding at instantiation time to appropriately handle
; generalization.  There is potential confusion in that the returned
; list may contain types that are not manifestly in TYPE but are in 
; the fully unwound tree associated with it.

(define (generic-tvariables type tenv)	;Compute FTV(type) - FTE(tenv)
  (match (prune type)
    ((tvariable->type tvar)
     (if (generic-tvariable? tvar tenv)
	 (list tvar)
	 (null)))
    ((compound->type _ operands)
     (letrec ((loop (lambda (ops tvars)
		      (if (null? ops)
			  tvars
			  (loop (cdr ops)
				(union (generic-tvariables (car ops) tenv) 
				       tvars))))))
       (loop operands (null))))
    ;; **MODULES**
    ((moduleof->type _ fields)
     (letrec ((loop (lambda (flds tvars)
		      (if (null? flds)
			  tvars
			  (loop (cdr flds)
				(union (generic-tvariables (car flds) tenv) 
				       tvars))))))
       (loop fields (null))))
    ;; **MODULES**
    ((base->type _) (null))
    (_ (error "This shouldn't happen!" (unparse-type type)))))

(define (union l1 l2)
  (cond ((null? l1) l2)
	((null? l2) l1)
	((in-tvariable-list? (car l1) l2) (union (cdr l1) l2))
	(else (cons (car l1) (union (cdr l1) l2)))))

(define (in-tvariable-list? tvar tvar-list)
  (if (null? tvar-list)
      #f
      (if (same-tvariable? tvar (car tvar-list))
	  #t
	  (in-tvariable-list? tvar (cdr tvar-list)))))

; Instantiate a type schema on a fresh set of type variables.
; [This corresponds to Cardelli's "FreshType".]

(define (instantiate-schema schema)
  (substitute-into-type 
   (map (lambda (g)
	  (tvariable->type (new-tvariable (tvariable-name g))))
	(schema-generics schema))
   (schema-generics schema)
   (schema-type schema)))

; [The following corresponds to Cardelli's "Fresh"; note the call to prune.]

; Note that this unwinds TYPE out to the leaves when doing the substitution;
; this guarantees that we don't miss any substitutions because type itself 
; isn't fully unwound.

(define (substitute-into-type types tvars type)
  (let ((type (prune type)))
    (match type
      ((tvariable->type tvar)
       (letrec ((loop (lambda (ts tvars)
			(if (null? ts)
			    type
			    (if (same-tvariable? tvar (car tvars))
				(car ts)
				(loop (cdr ts) (cdr tvars)))))))
	  (loop types tvars)))
      ((base->type _) type)
      ((compound->type c args)
       (compound->type c (map (lambda (arg)
				(substitute-into-type types tvars arg))
			      args)))
      ((moduleof->type names args)
       (moduleof->type names (map (lambda (arg)
				    (substitute-into-type types tvars arg))
				  args)))
      (_ (error "This shouldn't happen" (unparse-type type))))))

;;;----------------------------------------------------------------------------
;;; TYPE ENVIRONMENTS.
;
;  Environments can be extended in either of two ways:
;    extend-by-tvariables   should be used by lambda and letrec to bind
;      variables to type variables
;    extend-by-schemas  should be used by let and letrec to bind variables
;      to type schemas
;
;  Once constructed, there are two operations one can perform on a
;  type environment:
;    tlookup : tenv * var -> (tvar + schema)
;      does the usual thing.
;    generic-tvariable? : tvar * tenv -> bool   
;      returns true iff tvar is not free in the type of any var bound in tenv.

(define-datatype type-environment
  (make-type-env tlookup-proc generic-tvariable?-proc))

(define (tenv-lookup te)
  (match te
    ((make-type-env lookup generic?) lookup)))

(define (tenv-generic? te)
  (match te
    ((make-type-env lookup generic?) generic?)))

(define (extend-by-tvariables outer-tenv vars tvars)
  (extend-tenv outer-tenv
	       vars
	       (map tvar->tvar-or-schema tvars)
	       (lambda (tvar)
		 ;; tvar is an unconstrained type variable.
		 (letrec ((loop (lambda (tvars)
				  (if (null? tvars)
				      (generic-tvariable? tvar outer-tenv)
				      (if (occurs-in-type? 
					   tvar 
					   (tvariable->type (car tvars)))
					  ;; (same-tvariable? tvar (car tvars))
					  #f
					  (loop (cdr tvars)))))))
		   (loop tvars)))))

(define (extend-by-schemas outer-tenv vars schemas)
  (extend-tenv outer-tenv
	       vars
	       (map schema->tvar-or-schema schemas)
	       (lambda (tvar)
		 (generic-tvariable? tvar outer-tenv))))

;Students' code should not call this
(define (extend-tenv outer-tenv vars typas generic-tvariable?-proc)
  (make-type-env
   (lambda (var)
     (letrec ((loop (lambda (vars typas)
		      (if (null? vars)
			  (tlookup outer-tenv var)
			  (if (same-variable? var (car vars))
			      (car typas)
			      (loop (cdr vars) (cdr typas)))))))
       (loop vars typas)))
   generic-tvariable?-proc))

(define empty-type-environment
  (make-type-env
   (lambda (var) (error "Unbound variable: " (sym->sexp var)))
   (lambda (tvar) #t)))

(define (tlookup tenv var)
  ((tenv-lookup tenv) var))

(define same-variable? eq?)

(define (generic-tvariable? tvar tenv)
  ((tenv-generic? tenv) tvar))

; Proving the correctness of this implementation of GENERIC-TVARIABLE?
; is tricky.


;;;----------------------------------------------------------------------------
;;; TYPE VARIABLES

; A type variable is implemented as a record that contains a cell.  The
; global substitution is realized as the collective contents of the
; cells for all type variables.

(define-datatype tvariable
  (make-tvariable sym int (cellof type)))	; id gennum cell

(define (tvariable-name tvar)
  (match tvar
    ((make-tvariable name _ _) name)))

(define (tvariable-uid tvar)
  (match tvar
    ((make-tvariable _ uid _) uid)))

(define (tvariable-cell tvar)
  (match tvar
    ((make-tvariable _ _ c) c)))

(define tvariable-counter (cell 0))

(define (reset-tvariable-counter!)
  (:= tvariable-counter 0))

(define (new-tvariable id)
  (begin (:= tvariable-counter (+ (^ tvariable-counter) 1))
	 (make-tvariable id (^ tvariable-counter) (cell unknown-type))))

(define (tvariable-binding tvar)
  (^ (tvariable-cell tvar)))

(define (extend-substitution! tvar binding)
  (begin (:= (tvariable-cell tvar) binding)
	 #t))

(define (same-tvariable? tvar1 tvar2)
  (= (tvariable-uid tvar1) (tvariable-uid tvar2)))

(define unknown-type (unknown->type))

(define (tvariable->symbol tvar)
  (string->symbol
   (string-append "?" (symbol->string (tvariable-name tvar))
		  "-" (number->string (tvariable-uid tvar)))))


;;;----------------------------------------------------------------------------
;;; UNIFICATION
;;;
;;;  Has side effects.
;;;  Generates an error if there is no unification.

(define (unify! type1 type2)
  (if (unify!-internal type1 type2)
      #u
      (error "Type clash:  " 
	     (unparse-type type1) (unparse-type type2))))

(define (unify!-internal type1 type2)
  (let ((type1 (prune type1))
	(type2 (prune type2)))
    ;; Now if a type is a variable, it will be unbound
    (match type1
      ((tvariable->type v1)
       (match type2
	 ((tvariable->type v2)
	  (if (same-tvariable? v1 v2)
	      #t
	      (extend-substitution! v1 type2)))
	 (_
	  (if (occurs-in-type? v1 type2)
	      #f			;Circularity
	      (extend-substitution! v1 type2)))))
      ((base->type c1)
       (match type2
	 ((tvariable->type v2)
	  (extend-substitution! v2 type1))
	 ((base->type c2)
	  (same-name? c1 c2))
	 (_ #f)))
      ((compound->type con1 args1)
       (match type2
	 ((tvariable->type v2)
	  (if (occurs-in-type? v2 type1)
	      #f
	      (extend-substitution! v2 type1)))
	 ((compound->type con2 args2)
	  (if (same-constructor? con1 con2)
	      (unify!-list args1 args2)
	      #f))
	 (_ #f)))
      ((moduleof->type names1 args1)
       (match type2
	 ((tvariable->type v2)
	  (if (occurs-in-type? v2 type1)
	      #f
	      (extend-substitution! v2 type1)))
	 ((moduleof->type names2 args2)
	  (if (same-field-names? names1 names2)
	      (unify!-list args1 args2)
	      #f))
	 (_ #f))))))

(define (unify!-list types1 types2)
  (if (null? types1)
      (null? types2)
      (if (null? types2)
	  #f
	  (if (unify!-internal (car types1) (car types2))
	      (unify!-list (cdr types1) (cdr types2))
	      #f))))

; Chase substitutions of tvariables until either a non-tvariable or an
; unbound tvariable is found.

(define (prune type)
  (match type
    ((tvariable->type tvar)
     (match (tvariable-binding tvar)
       ((unknown->type) type)
       (other-type (prune other-type))))
    (_ type)))

; Occurs check: prevent circular substitutions.

(define (occurs-in-type? tvar type)
  (match (prune type)
    ((tvariable->type tvar2)
     ;; prune has guaranteed that tvar2 is unbound
     (same-tvariable? tvar tvar2))
    ((compound->type c args)
     (letrec ((loop (lambda (args)
		      (if (null? args)
			  #f
			  (or (occurs-in-type? tvar (car args))
			      (loop (cdr args)))))))
       (loop args)))
    ((moduleof->type names args)
     (letrec ((loop (lambda (args)
		      (if (null? args)
			  #f
			  (or (occurs-in-type? tvar (car args))
			      (loop (cdr args)))))))
       (loop args)))
    (_ #f)))


;;;----------------------------------------------------------------------------
;;; PARSING/UNPARSING -- old version with non-optimal strategy

; Parse a definition

(define (parse-definition sexp)
  (match sexp
    ;; Allow Scheme-style definitions ... 
    (`(define (,name ,@args) ,body)
     (make-definition (parse-formal name) 
		      (parse `(lambda ,args ,body))))
    (`(define ,name ,value)
     (make-definition (parse-formal name) (parse value)))
    (_ (error "Invalid definition: " sexp))))

(define (parse-formal sexp)
  (match sexp
    ((sym->sexp name)
     (if ((member? eq?) name all-keywords)
	 (error "Attempt to use reserved word as variable name" sexp)
	 name))
    (_ (error "Invalid variable name: " sexp))))

(define (parse-call operator operands)
  (call->exp (parse operator)
	     (map parse operands)))

(define (parse-binding-spec bspec)
  (match bspec
    (`(,name ,value) (make-definition (parse-formal name) (parse value)))
    (_ (error "Invalid binding specifier: " bspec))))

(define (syntax-error sexp)
  (error "Invalid expression syntax: " sexp))


; Parse a single expression

(define (parse sexp)			; sexp -> exp
  (match sexp
    ((unit->sexp)              (unit->exp))
    ((bool->sexp b)            (boolean->exp b))
    ((int->sexp n)             (integer->exp n))
    ((sym->sexp sym)           (variable->exp sym))
    ((string->sexp n)          (string->exp n))
    (`(,(sym->sexp head) ,@_)  ((parser-for-keyword head) sexp))
    ;; Procedure call is the default
    (`(,operator ,@operands)    (parse-call operator operands))
    (_ (error "Unrecognized expression " sexp))))

(define-datatype parser-table
  (make-parser-table (listof sym)
                     (-> (sym) (-> (sexp) exp))))

; Expressions of the form (reserved-word ...)

(define keyword-table
  (letrec 
      ((keywords (cell (null)))
       (lookup (cell (lambda (head)
		      (lambda (sexp)
			;; Procedure call is the default
			(match sexp
			  (`(,operator ,@operands)
			   (parse-call operator operands))
			  (_ (error "KEYWORD TABLE: This shouldn't happen!"
				   )))))))

       ;; DEFINE-KEYWORD is a function that defines a reserved word, 
       ;; associating it with a function that can parse the named construct.

       (define-keyword 
	 (lambda (keyword parser)
	   (let ((current-lookup (^ lookup)))
	     (begin (:= lookup
			(lambda (head)
			  (if (eq? head keyword)
			      parser
			      (current-lookup head))))
		    (:= keywords
			(cons keyword (^ keywords)))
		    keyword)))))
    (begin
      ;; List of parsing functions.  

      (define-keyword 'quote	; (quote Name)
	(lambda (sexp)
	  (match sexp
	    (`(quote ,(sym->sexp name))
	     (symbol->exp name))
	    (_ (syntax-error sexp)))))

      (define-keyword 'lambda	; (lambda (I*) E)
	(lambda (sexp)
	  (match sexp
	    (`(lambda (,@formals) ,body)
	     (lambda->exp (map parse-formal formals)
			  (parse body)))
	    (_ (syntax-error sexp)))))

      (define-keyword 'if	; (if E1 E2 E3)
	(lambda (sexp)
	  (match sexp
	    (`(if ,test ,con ,alt)
	     (if->exp (parse test)
		      (parse con)
		      (parse alt)))
	    (_ (syntax-error sexp)))))

      (define-keyword 'primop	; (primop O E*)
	(lambda (sexp)
	  (match sexp
	    (`(primop ,op ,@args)
	     ;; Assume valid primop -- type reconstruction will verify
	     ;; number of args.
	     (primop->exp op (map parse args)))
	    (_ (syntax-error sexp)))))

      (define-keyword 'let	; (let ((I E)*) E0)
	(lambda (sexp)
	  (match sexp
	    (`(let (,@bspecs) ,body)
	     (let->exp
	      (map parse-binding-spec bspecs)
	      (parse body)))
	    (_ (syntax-error sexp)))))

      (define-keyword 'letrec	; (letrec ((I E)*) E0)
	(lambda (sexp)
	  (match sexp
	    (`(letrec (,@bspecs) ,body)
	     (letrec->exp
	      (map parse-binding-spec bspecs)
	      (parse body)))
	    (_ (syntax-error sexp)))))

      (define-keyword 'set!	; (set! I E)
	(lambda (sexp)
	  (match sexp
	    (`(SET! ,(sym->sexp id) ,sexp)
	     (set!->exp id (parse sexp)))
	    (_ (syntax-error sexp)))))

      (define-keyword 'begin		; (begin E1 E2) + sugars
	(lambda (sexp)
	  (match sexp
	    (`(BEGIN) (unit->exp))
	    (`(BEGIN ,sexp) (parse sexp))
	    (`(BEGIN ,sexp1 ,sexp2) (begin->exp (parse sexp1) (parse sexp2)))
	    (`(BEGIN ,sexp1 ,sexp2 ,@rest)
	     (begin->exp (parse sexp1) (parse `(BEGIN ,sexp2 ,@rest))))
	    (_ (syntax-error sexp)))))


      ;; Sugar

      ;; (and)        ==>  #t
      ;; (and E)      ==>  E
      ;; (and E0 E+)  ==>  (if E0 (and E+) #f)
      ;;
      (define-keyword 'and
	(lambda (sexp)
	  (match sexp
	    (`(and ,@exp-list)
	     (parse (letrec ((recur (lambda (exps)
				      (match exps
					((null)           `#t)
					(`(,exp)            exp)
					((cons first rest)
					 `(if ,first ,(recur rest) #f))))))
		      (recur exp-list))))
	    (_ (syntax-error sexp)))))


      ;; (or)        ==>  #f
      ;; (or E)      ==>  E
      ;; (or E0 E+)  ==>  (if E0 #t (or E+))
      ;;
      (define-keyword 'or
	(lambda (sexp)
	  (match sexp
	    (`(or ,@exp-list)
	     (parse (letrec ((recur (lambda (exps)
				      (match exps
					((null)            `#f)
					(`(,exp)            exp)
					((cons first rest)
					 `(if ,first #t ,(recur rest)))))))
		      (recur exp-list))))
	    (_ (syntax-error sexp)))))

      ;; (cond (E E)* (else E))
      (define-keyword 'cond
	(lambda (sexp)
	  (match sexp
	    (`(cond) (syntax-error sexp))
	    (`(cond (else ,default)) 
	     (parse default))
	    (`(cond (,predicate ,consequent) ,@clauses)
	     (parse `(if ,predicate
			 ,consequent
			 (cond ,@clauses))))
	    )))

      ;; (list E*)
      ;;
      (define-keyword 'list
	(lambda (sexp)
	  (match sexp
	    (`(list ,@exp-list)
	     (parse (letrec ((recur (lambda (exps)
				      (match exps
					((null) `(null))
					((cons first rest)
					 `(cons ,first ,(recur rest)))))))
		      (recur exp-list))))
	    (_ (syntax-error sexp)))))

      ;; Module stuff

      (define-keyword 'module	; (module (define I E)*)
	(lambda (sexp)
	  (match sexp
	    (`(module ,@fspecs)
	     (module->exp
	      (map parse-definition fspecs)))
	    (_ (syntax-error sexp)))))

      (define-keyword 'with	; (with (I*) E1 E2)
	(lambda (sexp)
	  (match sexp
	    (`(with (,@formals) ,mod ,body)
	     (with->exp (map parse-formal formals)
			(parse mod)
			(parse body)))
	    (_ (syntax-error sexp)))))


      ;; Now return the whole parser table

      (make-parser-table (^ keywords)
			 (^ lookup))

      )))

(define parser-for-keyword 
  (match keyword-table
    ((make-parser-table keywords parser-lookup) parser-lookup)))

(define all-keywords
  (match keyword-table
    ((make-parser-table keywords parser-lookup) keywords)))


;;; Type expression parser

(define (parse-type sexp)
  (match sexp
    ((sym->sexp sym) (base->type sym))
    (`(-> (,@arg-types) ,result-type)
     (compound->type arrow-constructor
		     (cons (parse-type result-type)
			   (map parse-type arg-types))))
    ;; **MODULES**
    (`(moduleof ,@fields)
     (parse-module-type fields))
    ;; **MODULES**
    (`(,(sym->sexp name) ,@types)
     (compound->type name (map parse-type types)))
    (_ (error "Invalid type expression syntax " sexp))))

;; **MODULES**
(define (parse-module-type fields)
  (if (null? fields)
      (moduleof->type (null) (null))
      (match (parse-module-type (cdr fields))
        ((moduleof->type names typs)
	 (match (car fields)
           (`(val ,id ,typ) 
	    (moduleof->type (cons id names) (cons (parse-type typ) typs)))
	   (_ (error "Invalid syntax in moduleof field entry " 
		     (car fields)))))
	(_ (error  "PARSE-MODULE-TYPE: this shouldn't happen!"
		   fields)))))
;; **MODULES**

; Type expression unparser

(define (unparse-type type)
  (match (prune type)
    ((base->type sym) (sym->sexp sym))
    ((compound->type constructor operands)
     (if (same-constructor? constructor arrow-constructor)
	 `(-> (,@(map unparse-type (cdr operands)))
	      ,(unparse-type (car operands)))
	 `(,(sym->sexp constructor) ,@(map unparse-type operands))))
    ;; **MODULES**
    ((moduleof->type names operands)
     `(moduleof 
       ,@(map2 (lambda (id t) `(val ,(sym->sexp id) ,(unparse-type t)))
	       names
	       operands)))
    ;; **MODULES**
    ((tvariable->type tvar)
     (sym->sexp (tvariable->symbol tvar)))
    ((unknown->type)
     '(*unknown*))))

; Parse a type schema (generic (I*) T)

(define (parse-schema sexp)
  (match sexp
    (`(generic (,@names) ,type)
     (let ((names (map (lambda (name)
			 (match name
			   ((sym->sexp name) name)
			   (_ (error "Invalid type schema parameter: " name))))
		       names)))
       (let ((tvars (map new-tvariable names)))
	 (make-schema
	  tvars
	  (substitute-for-names (map tvariable->type tvars)
				names
				(parse-type type))))))
    (_ (make-schema (null) (parse-type sexp)))))

; substitute-for-names is a kludge, to be used only by initialization
; code.  Other ways to do this: 
; 
; (1) change the type parser to take an environment argument; 
;
; (2) generalize substitute-into-type so that it; can substitute for 
;     either names or tvars; 
;
; (3) change the representation of schemas so that the generic variables 
;     in the type are not tvars but rather names.

(define (substitute-for-names types names type)
  (match type
    ((tvariable->type _) type)		;shouldn't happen
    ((base->type name)
     (letrec ((loop (lambda (ts ns)
		      (if (null? ts)
			  type
			  (if (same-name? name (car ns))
			      (car ts)
			      (loop (cdr ts) (cdr ns)))))))
        (loop types names)))
    ((compound->type c args)
     (compound->type c (map (lambda (arg)
			      (substitute-for-names types names arg))
			    args)))
    ;; **MODULES**
    ((moduleof->type fieldnames args)
     (moduleof->type fieldnames (map (lambda (arg)
				       (substitute-for-names types names arg))
				     args)))
    ;; **MODULES**
    (_ (error "SUBSTITUTE-FOR-NAMES: This shouldn't happen! " 
	      (unparse-type type)))))

(define (unparse-schema s)
  (match s
    ((make-schema tvars type)
     `(generic (,@(map sym->sexp (map tvariable->symbol tvars)))
	       ,(unparse-type type)))))


;;;----------------------------------------------------------------------------
;;; STANDARD TYPE ENVIRONMENT

(define standard-type-bindings
  (list 
   ; Arithmetic
   '(+ (-> (int int) int))
   '(- (-> (int int) int))
   '(* (-> (int int) int))
   '(/ (-> (int int) int))

   ; Relational
   '(= (-> (int int) bool))
   '(/= (-> (int int) bool))
   '(< (-> (int int) bool))
   '(> (-> (int int) bool))
   '(<= (-> (int int) bool))
   '(>= (-> (int int) bool))

   ; Logical
   '(and? (-> (bool bool) bool))
   '(or?  (-> (bool bool) bool))
   '(not? (-> (bool) bool))

   ; Symbols
   '(sym=? (-> (sym sym) bool))

   ; Strings
   '(string=? (-> (sym sym) bool))

   ; Lists
   '(cons   (generic (t) (-> (t (list-of t)) (list-of t))))
   '(car    (generic (t) (-> ((list-of t)) t)))
   '(cdr    (generic (t) (-> ((list-of t)) (list-of t))))
   '(null   (generic (t) (-> () (list-of t))))
   '(null?  (generic (t) (-> ((list-of t)) bool)))
   '(append (generic (t) (-> ((list-of t) (list-of t)) (list-of t))))
   ))

(define standard-type-environment
  (extend-by-schemas empty-type-environment
		     (map (lambda (b)
			    (match b
			      (`(,(sym->sexp name) ,_) name)))
			  standard-type-bindings)
		     (map (lambda (b)
			    (match b
			      (`(,_ ,schema) (parse-schema schema))))
			  standard-type-bindings)))

;;;----------------------------------------------------------------------------
;;; UTILITIES

(define (member? pred)
  (lambda (elt lst)
    (letrec ((loop (lambda (lst)
		     (if (null? lst)
			 #f
			 (if (pred elt (car lst))
			     #t
			     (loop (cdr lst)))))))
      (loop lst))))

(define (map2 proc lst1 lst2)
  (if (or (null? lst1) (null? lst2))
      (null)
      (cons (proc (car lst1) (car lst2))
	    (map2 proc (cdr lst1) (cdr lst2)))))




;;;----------------------------------------------------------------------------
;;; TOP-LEVEL

(define (recon sexp)
  (begin (reset-tvariable-counter!)
	 (unparse-type (reconstruct (parse sexp)
				    standard-type-environment))))