; $Id: type-inf.scm,v 1.9 2008/01/28 09:20:12 logik Exp $
; 14. Hindley's Type Inference Algorithm
; ======================================

; The type free expressions may be introduced as elements of an
; appropriate free algebra.  We can then perform type inference with
; Hindley's algorithm.  This may be useful for a simple method to input
; terms, where typability is checked and the most general type is
; inferred (as in ML).

; eqs has the form ((type11 type12) (type21 type22) ...), considered as
; a list of equations.  It is assumed that all types are built from type
; variables by arrow and star.  type-martmont implements the
; Martelli-Montanari unification algorithm (cf proofth/ss01/pt.tex).

; We may also extract the Martelli-Montanari unification algorithm as
; well as Hindley's type inference algorithm from the corresponding
; proofs. Then we would need to introduce the data structures as free
; algebras.  However, for simplicity we do not do this at the moment.

(define (type-occurs? tvar type)
  (or (equal? tvar type)
      (and (arrow-form? type)
	   (or (type-occurs? tvar (arrow-form-to-arg-type type))
	       (type-occurs? tvar (arrow-form-to-val-type type))))
      (and (star-form? type)
	   (or (type-occurs? tvar (star-form-to-left-type type))
	       (type-occurs? tvar (star-form-to-right-type type))))))

(define (type-martmont eqs)
  (if
   (null? eqs)
   empty-subst
   (let* ((first (car eqs))
	  (l (car first))
	  (r (cadr first)))
     (if (tvar? l)
	 (if (equal? l r)
	     (type-martmont (cdr eqs))
	     (if (type-occurs? l r)
		 #f
		 (let ((prev (type-martmont
			      (map (lambda (x)
				     (list (type-subst (car x) l r)
					   (type-subst (cadr x) l r)))
				   (cdr eqs)))))
		   (if prev
		       (compose-t-substitutions
			(list (list l r))
			prev)
		       #f))))
	 (if (tvar? r)
	     (type-martmont (cons (list r l) (cdr eqs)))
	     (cond
	      ((and (arrow-form? l) (arrow-form? r))
	       (type-martmont (cons (list (arrow-form-to-arg-type l)
					  (arrow-form-to-arg-type r))
				    (cons (list (arrow-form-to-val-type l)
						(arrow-form-to-val-type r))
					  (cdr eqs)))))
	      ((and (star-form? l) (star-form? r))
	       (type-martmont (cons (list (star-form-to-left-type l)
					  (star-form-to-left-type r))
				    (cons (list (star-form-to-right-type l)
						(star-form-to-right-type r))
					  (cdr eqs)))))
	      (else #f)))))))

; Complete test:

(define (tvar-arrow-star-type? x)
  (and (type-form? x)
       (case (tag x)
	 ((tvar) (tvar? x))
	 ((arrow) (and (tvar-arrow-star-type? (arrow-form-to-arg-type x))
		       (tvar-arrow-star-type? (arrow-form-to-val-type x))))
	 ((star) (and (tvar-arrow-star-type? (star-form-to-left-type x))
		      (tvar-arrow-star-type? (star-form-to-right-type x))))
	 (else #f))))

(define (type-unify type1 type2)
  (if (and (tvar-arrow-star-type? type1) (tvar-arrow-star-type? type2))
      (type-martmont (list (list type1 type2)))
      (myerror "type-unify: tvar-arrow-star-types expected" type1 type2)))

(define (type-unify-list types1 types2)
  (type-unify (apply mk-arrow types1) (apply mk-arrow types2)))  

; Test

(display-t-substitution
 (type-unify-list
  (list (py "alpha2=>alpha2") (py "alpha1=>(alpha1=>alpha1)=>alpha2"))
  (list (py "alpha1") (py "(alpha3=>alpha3)=>alpha4=>alpha3"))))
; alpha1	->	alpha3=>alpha3
; alpha2	->	alpha3
; alpha4	->	(alpha3=>alpha3)=>alpha3=>alpha3

; We implement Hindley's algorithm.  Given a type-free lambda-term, the
; algorithm decides whether it admits a typing, and if so, computes a
; principal one.  If there is no typing, it returns #f.

; Type free lambda-terms are viewed as Scheme expressions, for instance
; (u15 (lambda (u16) (u16 (lambda (u17) (u15 (lambda (u18) u17))))))

; Typings are of the form (((var1 chi1) ... (varn chin)) phi).

(define (expr-app-form? x)
  (and (list? x) (= 2 (length x))))

(define expr-app-form-to-op car)
(define expr-app-form-to-arg cadr)

(define (expr-lambda-form? x)
  (and (list? x) (= 3 (length x))
       (eq? 'lambda (car x))
       (list (cadr x))
       (= 1 (length (cadr x)))))

(define expr-in-abst-form-to-symbol caadr)
(define expr-in-abst-form-to-kernel caddr)

(define (expr-pair-form? x)
  (and (list? x) (= 3 (length x)) (eq? 'cons (car x))))

(define expr-pair-form-to-left cadr)
(define expr-pair-form-to-right caddr)

(define (expr-left-comp-form? x)
  (and (list? x) (= 2 (length x)) (eq? 'car (car x))))

(define expr-left-comp-form-to-kernel cadr)

(define (expr-right-comp-form? x)
  (and (list? x) (= 2 (length x)) (eq? 'cdr (car x))))

(define expr-right-comp-form-to-kernel cadr)

(define (type-inf expr)
  (cond
   ((symbol? expr)
    (let ((typevar (new-tvar)))
      (list (list (list expr typevar)) typevar)))
   ((expr-app-form? expr)
    (let ((prev1 (type-inf (expr-app-form-to-op expr)))
	  (prev2 (type-inf (expr-app-form-to-arg expr))))
      (if (or (not prev1) (not prev2))
	  #f
	  (let* ((vars1 (map car (car prev1)))
		 (vars2 (map car (car prev2)))
		 (ws (intersection vars1 vars2))
		 (sigmas (do ((x (car prev1) (cdr x))
			      (res '() (if (memq (caar x) ws)
					   (cons (cadar x) res)
					   res)))
			     ((null? x) (reverse res))))
		 (taus (do ((x (car prev2) (cdr x))
			    (res '() (if (memq (caar x) ws)
					 (cons (cadar x) res)
					 res)))
			   ((null? x) (reverse res))))
		 (typevar (new-tvar))
		 (mgu (type-unify-list
		       (cons (cadr prev1) sigmas)
		       (cons (make-arrow (cadr prev2) typevar)
			     taus))))
	    (if (not mgu)
		(begin
		  (display "; Typing impossible.  One can still type ")
		  (display (expr-app-form-to-op expr)) (display " with ")
		  (display (type-to-string (cadr prev1)))
		  (if (null? (car prev1))
		      (newline)
		      (begin
			(display " from") (newline) (display "; ")
			(do ((c (car prev1) (cdr c)))
			    ((null? c) (newline))
			  (display "  ") (display (caar c)) (display ":")
			  (display (type-to-string (cadar c)))
			  (if (pair? (cdr c))
			      (begin (newline) (display "; "))))))
		  (display "; and ")
		  (display (expr-app-form-to-arg expr)) (display " with ")
		  (display (type-to-string (cadr prev2)))
		  (if (null? (car prev2))
		      (newline)
		      (begin
			(display " from") (newline) (display "; ")
			(do ((c (car prev2) (cdr c)))
			    ((null? c) (newline))
			  (display "  ") (display (caar c)) (display ":")
			  (display (type-to-string (cadar c)))
			  (if (pair? (cdr c))
			      (begin (newline) (display "; "))))))
		  (display "; However, unification failed at this stage.")
		  (newline)
		  #f)
		(list (remove-duplicates
		       (map (lambda (x)
			      (list (car x)
				    (type-substitute (cadr x) mgu)))
			    (append (car prev1) (car prev2))))
		      (type-substitute typevar mgu)))))))
   ((expr-lambda-form? expr)
    (let* ((symbol (expr-in-abst-form-to-symbol expr))
	   (kernel (expr-in-abst-form-to-kernel expr))
	   (prev (type-inf kernel)))
      (if (not prev)
	  #f
	  (let ((info (assq symbol (car prev))))
	    (if info
		(list (remove info (car prev))
		      (make-arrow (cadr info) (cadr prev)))
		(list (car prev)
		      (make-arrow (new-tvar) (cadr prev))))))))
   ((expr-pair-form? expr)
    (let ((prev1 (type-inf (expr-pair-form-to-left expr)))
	  (prev2 (type-inf (expr-pair-form-to-right expr))))
      (if (or (not prev1) (not prev2))
	  #f
	  (let* ((vars1 (map car (car prev1)))
		 (vars2 (map car (car prev2)))
		 (ws (intersection vars1 vars2))
		 (sigmas (do ((x (car prev1) (cdr x))
			      (res '() (if (memq (caar x) ws)
					   (cons (cadar x) res)
					   res)))
			     ((null? x) (reverse res))))
		 (taus (do ((x (car prev2) (cdr x))
			    (res '() (if (memq (caar x) ws)
					 (cons (cadar x) res)
					 res)))
			   ((null? x) (reverse res))))
		 (mgu (type-unify-list sigmas taus)))
	    (if (not mgu)
		(begin
		  (display "; Typing impossible.  One can still type ")
		  (display (expr-pair-form-to-left expr)) (display " with ")
		  (display (type-to-string (cadr prev1)))
		  (if (null? (car prev1))
		      (newline)
		      (begin
			(display " from") (newline) (display "; ")
			(do ((c (car prev1) (cdr c)))
			    ((null? c) (newline))
			  (display "  ") (display (caar c)) (display ":")
			  (display (type-to-string (cadar c)))
			  (if (pair? (cdr c))
			      (begin (newline) (display "; "))))))
		  (display "; and ")
		  (display (expr-pair-form-to-right expr)) (display " with ")
		  (display (type-to-string (cadr prev2)))
		  (if (null? (car prev2))
		      (newline)
		      (begin
			(display " from") (newline) (display "; ")
			(do ((c (car prev2) (cdr c)))
			    ((null? c) (newline))
			  (display "  ") (display (caar c)) (display ":")
			  (display (type-to-string (cadar c)))
			  (if (pair? (cdr c))
			      (begin (newline) (display "; "))))))
		  (display "; However, unification failed at this stage.")
		  (newline)
		  #f)
		(list (remove-duplicates
		       (map (lambda (x)
			      (list (car x)
				    (type-substitute (cadr x) mgu)))
			    (append (car prev1) (car prev2))))
		      (make-star (type-substitute (cadr prev1) mgu)
				 (type-substitute (cadr prev2) mgu))))))))
   ((expr-left-comp-form? expr)
    (let* ((kernel (expr-left-comp-form-to-kernel expr))
	   (prev (type-inf kernel)))
      (if (not prev)
	  #f
	  (let* ((tvar1 (new-tvar))
		 (tvar2 (new-tvar))
		 (mgu (type-unify (cadr prev) (make-star tvar1 tvar2))))
	    (if (not mgu)
		(begin
		  (display "; Typing impossible.  One can still type ")
		  (display kernel) (display " with ")
		  (display (type-to-string (cadr prev)))
		  (if (null? (car prev))
		      (newline)
		      (begin
			(display " from") (newline) (display "; ")
			(do ((c (car prev) (cdr c)))
			    ((null? c) (newline))
			  (display "  ") (display (caar c)) (display ":")
			  (display (type-to-string (cadar c)))
			  (if (pair? (cdr c))
			      (begin (newline) (display "; "))))))
		  (display "; However, unification with tvar1;tvar2")
		  (display " failed at this stage.")
		  (newline)
		  #f)
		(list (remove-duplicates
		       (map (lambda (x)
			      (list (car x)
				    (type-substitute (cadr x) mgu)))
			    (car prev)))
		      (type-substitute tvar1 mgu)))))))
   ((expr-right-comp-form? expr)
    (let* ((kernel (expr-right-comp-form-to-kernel expr))
	   (prev (type-inf kernel)))
      (if (not prev)
	  #f
	  (let* ((tvar1 (new-tvar))
		 (tvar2 (new-tvar))
		 (mgu (type-unify (cadr prev) (make-star tvar1 tvar2))))
	    (if (not mgu)
		(begin
		  (display "; Typing impossible.  One can still type ")
		  (display kernel) (display " with ")
		  (display (type-to-string (cadr prev)))
		  (if (null? (car prev))
		      (newline)
		      (begin
			(display " from") (newline) (display "; ")
			(do ((c (car prev) (cdr c)))
			    ((null? c) (newline))
			  (display "  ") (display (caar c)) (display ":")
			  (display (type-to-string (cadar c)))
			  (if (pair? (cdr c))
			      (begin (newline) (display "; "))))))
		  (display "; However, unification with tvar1;tvar2")
		  (display " failed at this stage.")
		  (newline)
		  #f)
		(list (remove-duplicates
		       (map (lambda (x)
			      (list (car x)
				    (type-substitute (cadr x) mgu)))
			    (car prev)))
		      (type-substitute tvar2 mgu)))))))
   (else
    (myerror "type-inf: expression expected" expr))))

; Tests
; (type-inf 'x)
; (type-inf '(x y))
; (type-inf '(x x))
; (type-inf '(lambda (x) (y x)))
; (type-inf '(lambda (x) (x x)))
; (type-inf '(lambda (x) (lambda (y) (lambda (z) ((x z) (y z))))))

(define (ti expr)
  (let ((prev (type-inf expr)))
    (if prev
        (let* ((alist (car prev))
               (phi (cadr prev)))
	  (display "; A principal typing is") (newline)
          (display "; ") (display (type-to-string phi))
          (if (null? alist)
              (newline)
              (begin
                (display " from") (newline) (display "; ")
                (do ((c alist (cdr c)))
                    ((null? c) (newline))
                  (display "  ") (display (caar c)) (display ":")
		  (display (type-to-string (cadar c)))
		  (if (pair? (cdr c))
                      (begin (newline) (display "; ")))))))
	(myerror "ti: typeable expression expected" expr))))

; (ti 'x)
; (ti '(lambda (x) (lambda (y) (lambda (z) ((x z) (y z))))))

; (ti '(u15 (lambda (u16) (u16 (lambda (u17) (u15 (lambda (u18) u17)))))))
; =>
; A principal typing is
; p22 from
;  u15:(((p19 -> p22) -> p19) -> p19) -> p22

; 2. (ti '(lambda (u) (lambda (v) (lambda (w) (u (u (v (v w))))))))
; =>
; A principal typing is
; (p25 -> p25) -> (p25 -> p25) -> p25 -> p25

; This example shows that the formula inferred by type inference can
; be an instance of a more general derivable formula.

; Literature: Hindley 69, and my lecture `Typentheorie' SS92.


