home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / tdecl / kind-inference.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  7.2 KB  |  199 lines  |  [TEXT/CCL2]
  1. olist (alg (module-alg-defs *module*))
  2.        (let* ((sig (algdata-signature alg))
  3.           (env (map (function get-class-kind-constraints)
  4.             (gtype-context sig))))
  5.      (dolist (con (algdata-constrs alg))
  6.        (setf *remembered-kind-obj* con)
  7.        (kind-unify/star
  8.         (kind-inference/ntype
  9.          (gtype-type (con-signature con)) env)))
  10.      (setf *remembered-kind-obj* alg)
  11.      (kind-unify (tycon-def-k alg) (make-kind-app/star env))))
  12.      (dolist (class (module-class-defs *module*))
  13.        (let ((kind (class-k class)))
  14.      (dolist (c1 (class-super class))
  15.        (setf *remembered-kind-obj* class)
  16.            (kind-unify kind (class-k c1)))
  17.      (dolist (m (class-method-vars class))
  18.        (let* ((sig (var-type m))
  19.           (env (map (function get-class-kind-constraints)
  20.                 (gtype-context sig))))
  21.        (setf *remembered-kind-obj* m)
  22.          (kind-unify/star
  23.           (kind-inference/ntype (gtype-type sig) env))))))))
  24.   (walk-modules modules
  25.    (lambda ()
  26.      (dolist (alg (module-alg-defs *module*))
  27.        (setf (tycon-def-k alg) (kind-prune/recursive (tycon-def-k alg)))
  28.        (setf (tycon-def-arity alg) (compute-kind-arity (tycon-def-k alg))))
  29.      (dolist (class (module-class-defs *module*))
  30.        (setf (class-k class) (kind-prune/recursive (class-k class))))
  31.      (dolist (syn (module-synonym-defs *module*))
  32.        (mlet ((ty (**tycon/def syn (map (function **tyvar) (synonym-args syn))))
  33.           (gty (ast->gtype/vars '() ty (synonym-args syn)))
  34.           (env (map (function **kind-var) (gtype-context gty)))
  35.           (k (kind-inference/ntype (gtype-type gty) env))
  36.           ((k1 res) (make-kind-app env)))
  37.      (setf *remembered-kind-obj* syn)
  38.          (kind-unify res k)
  39.      (setf (tycon-def-k syn) (kind-prune/recursive k1))
  40.      (setf (tycon-def-arity syn) (compute-kind-arity (tycon-def-k syn)))
  41.      (format '#t "Kind of ~A is ~A~%" syn (tycon-def-k syn))))
  42.      ;; Fill in kinds for all gtypes in algs, classes, synonyms, insts(?)
  43.      (dolist (alg (module-alg-defs *module*))
  44.        (format '#t "Kind of ~A is ~A~%" alg (tycon-def-k alg))
  45.        (add-gtype-kinds (algdata-signature alg))
  46.        (dolist (c (algdata-constrs alg))
  47.          (add-gtype-kinds (con-signature c))))
  48.      (dolist (c (module-class-defs *module*))
  49.        (format '#t "Kind of ~A is ~A~%" c (class-k c))
  50.        (dolist (m (class-method-vars c))
  51.      (add-gtype-kinds (var-type m))))
  52.      )))
  53.  
  54. (define (kind-inference/gtype gtype)
  55.   (let ((kind-env (map (function get-class-kind-constraints)
  56.                (gtype-context gtype))))
  57.     (kind-inference/ntype (gtype-type gtype) kind-env)))
  58.  
  59. ;;; This determines an initial kind constraint for a type variable.  The
  60. ;;; kinds of all classes are unified.
  61.  
  62. (define (get-class-kind-constraints ctxt)
  63.   (if (null? ctxt)
  64.       (**kind-var)
  65.       (let ((res (class-k (car ctxt))))
  66.     (dolist (c (cdr ctxt))
  67.        (kind-unify res (class-k c)))
  68.     res)))
  69.  
  70. ;;; This does the actual kind inference.
  71.  
  72. (define (kind-inference/ntype ty env)
  73.   (cond ((gtyvar? ty)
  74.      (list-ref env (gtyvar-varnum ty)))
  75.     ((ntycon? ty)
  76.      (or (tycon-def-k (ntycon-tycon ty))
  77.          (fatal-error 'undefined-kind "Undefined kind for ~A" ty)))
  78.     ((ty-app? ty)
  79.      (let ((fn (ty-app-fn ty)))
  80.        (if (and (ntycon? fn)
  81.             (synonym? (ntycon-tycon fn))
  82.             (not (tycon-def-k (ntycon-tycon fn))))
  83.            (kind-inference/ntype (expand-ntype-synonym ty) env)
  84.            (let ((fn-type (kind-inference/ntype fn env))
  85.              (arg-types
  86.               (map (lambda (ty1) (kind-inference/ntype ty1 env))
  87.                (ty-app-args ty))))
  88.          (kind-unify/app fn-type arg-types)))))
  89.     (else (error "Bad type in kind-inference/ntype"))))
  90.  
  91. (define (kind-unify k1 k2)
  92.   (let ((k1 (kind-prune k1))
  93.     (k2 (kind-prune k2)))
  94.     (cond ((eq? k1 k2)
  95.        'OK)
  96.       ((kind-var? k1)
  97.        (setf (kind-var-value k1) k2))
  98.       ((kind-var? k2)
  99.        (setf (kind-var-value k2) k1))
  100.       ((and (star? k1) (star? k2))
  101.        'OK)
  102.       ((and (k-app? k1) (k-app? k2))
  103.        (kind-unify (k-app-arg k1) (k-app-arg k2))
  104.        (kind-unify (k-app-res k1) (k-app-res k2)))
  105.       (else
  106.        (kind-unification-error)))))
  107.  
  108. (define (kind-unify/app fn args)
  109.   (if (null? args)
  110.       fn
  111.       (let ((fn (kind-prune fn)))
  112.     (cond ((star? fn)
  113.            (kind-unification-error))
  114.           ((kind-var? fn)
  115.            (mlet (((fn-type res-type) (make-kind-app args)))
  116.              (setf (kind-var-value fn) fn-type)
  117.              res-type))
  118.           ((k-app? fn)
  119.            (kind-unify (k-app-arg fn) (car args))
  120.            (kind-unify/app (k-app-res fn) (cdr args)))
  121.           (else (error "Bad type in kind-unify"))))))
  122.  
  123. (define (make-kind-app args)
  124.   (if (null? args)
  125.       (let ((ty (**kind-var)))
  126.     (values ty ty))
  127.       (mlet (((fn-type res-type) (make-kind-app (cdr args))))
  128.         (values (**k-app (car args) fn-type) res-type))))
  129.  
  130. (define (make-kind-app/star args)
  131.   (if (null? args)
  132.       (**star)
  133.       (**k-app (car args) (make-kind-app/star (cdr args)))))
  134.  
  135. (define (kind-unify/star k)
  136.   (let ((k (kind-prune k)))
  137.     (cond ((kind-var? k)
  138.        (setf (kind-var-value k) (**star)))
  139.       ((star? k)
  140.        'OK)
  141.       (else
  142.        (kind-unification-error)))))
  143.  
  144. ;;; This also handles defaulting
  145.  
  146. (define (kind-prune/recursive k)
  147.   (cond ((star? k)     k)
  148.     ((kind-var? k) (if (kind-var-value k)
  149.                (kind-prune/recursive (kind-var-value k))
  150.                (**star)))
  151.     ((k-app? k)    (**k-app (kind-prune/recursive (k-app-arg k))
  152.                 (kind-prune/recursive (k-app-res k))))))
  153.  
  154. ;;; Kinds that correspond to ordinary type constructor arities are treated
  155. ;;; separately.  These are *, * -> *, * -> (* -> *), ...
  156.  
  157. (define (compute-kind-arity k)
  158.   (cond ((star? k)   0)
  159.     ((k-app? k)  (let ((a (compute-kind-arity (k-app-res k))))
  160.                (if (and a (star? (k-app-arg k)))
  161.                (1+ a)
  162.                '#f)))
  163.     (else         (error "Bad kind"))))
  164.  
  165. ;;; This augments a gtype with kinds for both tyvars and applications.
  166.  
  167. (define (add-gtype-kinds gtype)
  168.   (setf *remembered-kind-obj* gtype)
  169.   (let* ((env (map (function get-class-kind-constraints)
  170.            (gtype-context gtype)))
  171.      (k (kind-inference/ntype (gtype-type gtype) env))
  172.      (ks (map (function kind-prune/recursive) env)))
  173.     (kind-unify/star k)
  174.     (unless (every (function star?) ks)
  175.     (setf (gtype-kinds gtype) ks))
  176.     (add-gtype-kinds/internal (gtype-type gtype) ks)))
  177.  
  178. ;;; This is used to decorate internal nodes of the gtype
  179.  
  180.  
  181. (define (add-gtype-kinds/internal ty env)
  182.   (cond ((gtyvar? ty)
  183.      (list-ref env (gtyvar-varnum ty)))
  184.     ((ntycon? ty)
  185.      (setf (ntype-kind ty) (tycon-def-k (ntycon-tycon ty))))
  186.     (else
  187.      (let ((fn (add-gtype-kinds/internal (ty-app-fn ty))))
  188.        (dolist (a (ty-app-args ty))
  189.             (add-gtype-kinds/internal a env)
  190.          (setf fn (k-app-res fn)))
  191.        (setf (ntype-kind ty) fn)))))
  192.  
  193. (define (kind-unification-error)
  194.   (phase-error/objs 'kinding-error (list *remembered-kind-obj*)
  195.      "Kind conflict while inferring kind for ~A"
  196.      (if (gtype? *remembered-kind-obj*)
  197.      *remembered-kind-obj*
  198.      (get-object-name *remembered-kind-obj*))))
  199.