home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / derived / derived-instances.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  9.7 KB  |  235 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; Basic DI structure:
  3. ;;;  a. Create the set of instances
  4. ;;;  b. Expand the context of each potential instance.
  5. ;;;  c. Once b. reaches a fixpoint, fill in the ast for the generated instances
  6.  
  7. (define *di-context-changed* '#f)
  8.  
  9. (define (add-derived-instances modules)
  10.   (let ((insts '()))
  11.     (walk-modules modules
  12.      (lambda () (setf insts (append (find-derivable-instances '#f) insts))))
  13.     (walk-modules (get-all-interfaces)
  14.      (lambda ()
  15.        (when (interface-module? (locate-module *module-name*))
  16.          (setf insts (append (find-derivable-instances '#t) insts)))))
  17.     (check-di-preconditions insts)
  18.     (compute-di-fixpoint insts)
  19. ;;; Derived instances which come from interfaces are treated specially.
  20. ;;; They must participate in the fixpoint process but are not attached to
  21. ;;; any module.  The are linked in the class but not placed in instance-defs.
  22.     (dolist (icp insts)
  23.      (let ((inst (car icp)))
  24.       (when (instance-ok? inst)
  25.        (if (instance-in-interface? inst)
  26.     (expand-instance-decls inst '#t) ; do this now since not in a module
  27.     (push inst (module-instance-defs
  28.             (locate-module (def-module (instance-algdata inst)))))))))))
  29.  
  30. ;;; Create instance decls for all derived instances in a module.  Filter
  31. ;;; out underivable instances (Ix & Enum only)
  32.  
  33. (define (find-derivable-instances interface?)
  34.   (let ((algs (module-alg-defs *module*))
  35.     (insts '()))
  36.     (dolist (alg algs)
  37.       (dolist (d (algdata-deriving alg))
  38.      (dolist (di (deriving-instances d))
  39.         (let ((i (add-derivable-instance di alg d interface?)))
  40.           (when i (push i insts))))))
  41.     insts))
  42.  
  43. ;; This adds a provisional instance template.  Of course, there may already
  44. ;;; be an instance (error!)
  45.  
  46. (define (add-derivable-instance inst-decl alg d interface?)
  47.   (setf alg (forward-def alg))
  48.   (let* ((cls (forward-def (class-ref-class (instance-decl-class inst-decl))))
  49.      (existing-inst (lookup-instance alg cls))
  50.      (c (deriving-preconditions d)))
  51.     (cond ((or (eq? existing-inst '#f) 
  52.            (and (not interface?) (instance-in-interface? existing-inst)))
  53.        ;; This links it in so that locate-instance can find it
  54.        (let ((inst (new-instance cls alg (algdata-tyvars alg)))
  55.          (fc (expand-special-context
  56.               (instance-decl-context inst-decl) alg)))
  57. ;;; %%% I think we also need superclass contexts here  - jcp
  58.          (setf (instance-context inst) (algdata-context alg))
  59.          (setf (ast-node-line-number inst)
  60.            (def-where-defined alg))
  61.          (setf (instance-decls inst)
  62.            (if interface?
  63.                '()
  64.                (create-instance-fns inst inst-decl)))
  65.          (setf (instance-ok? inst) '#t)
  66.          (setf (instance-in-interface? inst) interface?)
  67.          (unless interface?
  68.            (setf (instance-runtime-var inst)
  69.             (make-new-var (string-append
  70.                    (symbol->string (def-name cls))
  71.                    "-"
  72.                    (symbol->string (def-name alg))
  73.                    "-instance"))))
  74.          (list inst fc c)))
  75.       (interface? '#f) ; there may be more than one
  76.       (else
  77.        (recoverable-error 'instance-exists
  78.           "An instance for type ~A in class ~A already exists;~%~
  79.                   the deriving clause is being ignored."
  80.            alg cls)
  81.        '#f))))
  82.  
  83. (define (check-di-preconditions insts)
  84.   (dolist (icp insts)
  85.     (let* ((i (car icp))
  86.        (c (caddr icp))
  87.        (alg (forward-def (instance-algdata i))))
  88.       (dolist (class-ref c)
  89.        (let ((class (class-ref-class class-ref)))
  90.     (cond ((eq? class (core-symbol "EnumType"))
  91.            (when (not (algdata-enum? alg))
  92.          (signal-instance-requires i "enumerated")
  93.          (setf (instance-ok? i) '#f)))
  94.           ((eq? class (core-symbol "EnumOrTupleType"))
  95.            (when (not (or (algdata-enum? alg) (algdata-tuple? alg)))
  96.          (signal-instance-requires i "enumerated or single constructor")
  97.          (setf (instance-ok? i) '#f)))
  98.           (else
  99.            (let ((i1 (lookup-instance alg class)))
  100.          (when (not i1)
  101.                 (signal-instance-requires-class i class)
  102.            (setf (instance-ok? i) '#f))))))))))
  103.  
  104. (define (signal-instance-requires inst thing)
  105.   (phase-error 'cannot-derive-instance
  106.     "The instance ~A cannot be derived.~%~A is not an ~A type."
  107.      (get-object-name inst) (get-object-name (instance-algdata inst)) thing))
  108.  
  109. (define (signal-instance-requires-class inst class)
  110.   (phase-error 'cannot-derive-instance
  111.     "The instance ~A cannot be derived.  ~A is not in class ~A."
  112.      (get-object-name inst) (get-object-name (instance-algdata inst))
  113.      (get-object-name class)))
  114.  
  115. ;;; This expands the context of an instance declaration in a deriving clause.
  116. ;;; The context C |t expands to C t_i for all the t_i at the top level of
  117. ;;; the type.
  118.  
  119. (define (expand-special-context c alg)
  120.   (let ((res '()))
  121.     (dolist (constr (algdata-constrs (forward-def alg)))
  122.       (dolist (ty (con-types constr))
  123.         (dolist (ctxt c)
  124.       (push (list (class-ref-class (context-class ctxt)) ty) res))))
  125.     res))
  126.  
  127. ;;; This is the instance context fixpoint routine.
  128.  
  129. (define (compute-di-fixpoint insts)
  130.   (setf *di-context-changed* '#f)
  131.   (dolist (inst insts)
  132.     (propagate-di-context (car inst) (cadr inst)))
  133.   (when *di-context-changed* (compute-di-fixpoint insts)))
  134.  
  135. (define (propagate-di-context inst c)
  136.  (when (instance-ok? inst)
  137.     (dolist (ct c)
  138.       (let* ((class (car ct))
  139.          (type (cadr ct))
  140.          (implied-classes (propagate-ast-context class type)))
  141.     (cond ((eq? implied-classes 'fail)
  142.            (phase-error 'canot-derive-instance
  143.             "The instance ~A(~A) cannot be derived.~%Context ~A(~A) failed."
  144.              (instance-class inst) (instance-algdata inst)
  145.          class type)
  146.            (setf (instance-ok? inst) '#f)
  147.            (setf *di-context-changed* '#t))
  148.           (else
  149.            (dolist (ct1 implied-classes)
  150.          (augment-instance-context
  151.           inst
  152.           (class-ref-class (context-class ct1))
  153.           (context-tyvar ct1)))))))))
  154.  
  155. ;;; This is the basic context propagation routine.  It takes a class and
  156. ;;; a type and returns either 'fail or a context.
  157.  
  158. (define (propagate-ast-context class type)
  159.   (if (tyvar? type)
  160.       (list (**context (**class/def class) (tyvar-name type)))
  161.       (let ((tycon (tycon-def type)))
  162.     (if (synonym? tycon)
  163.         (propagate-ast-context class (expand-synonym type))
  164.         (let ((i (lookup-instance (tycon-def type) class))
  165.           (args (tycon-args type)))
  166.           (if (or (not i) (not (instance-ok? i)))
  167.           'fail
  168.           (propagate-instance-contexts
  169.              (instance-context i) (instance-tyvars i) args)))))))
  170.  
  171. ;;; Here's the plan for expanding Cls(Alg t1 t2 .. tn) using
  172. ;;; instance (Cls1(vx),Cls2(vy),...) => Cls(Alg(v1 v2 .. vn))
  173. ;;;   for each Clsx in the instance context, propagate Clsx to the
  174. ;;;   ti corresponding to vx, where vx must be in the set vi.
  175.  
  176. (define (propagate-instance-contexts contexts tyvars args)
  177.   (if (null? contexts)
  178.       '()
  179.       (let ((c1 (propagate-ast-context
  180.          (class-ref-class (context-class (car contexts)))
  181.          (find-corresponding-tyvar
  182.           (context-tyvar (car contexts)) tyvars args))))
  183.     (if (eq? c1 'fail)
  184.         'fail
  185.         (append c1 (propagate-instance-contexts 
  186.             (cdr contexts) tyvars args))))))
  187.  
  188. ;;; Given the t(i) and the v(i), return the t corresponding to a v.
  189.  
  190. (define (find-corresponding-tyvar tyvar tyvars args)
  191.   (if (eq? tyvar (car tyvars))
  192.       (car args)
  193.       (find-corresponding-tyvar tyvar (cdr tyvars) (cdr args))))
  194.  
  195. ;;; 1 level type synonym expansion
  196.  
  197. (define (expand-synonym type)
  198.   (let* ((synonym (tycon-def type))
  199.      (args (synonym-args synonym))
  200.      (body (synonym-body synonym)))
  201.   (let ((alist (map (lambda (tyvar arg) (tuple tyvar arg))
  202.             args (tycon-args type))))
  203.     (copy-synonym-body body alist))))
  204.  
  205. (define (copy-synonym-body type alist)
  206.   (if (tyvar? type)
  207.       (tuple-2-2 (assq (tyvar-name type) alist))
  208.       (make tycon (def (tycon-def type))
  209.               (name (tycon-name type))
  210.           (args (map (lambda (ty)
  211.                    (copy-synonym-body ty alist))
  212.                  (tycon-args type))))))
  213.  
  214. ;;; This extends the context of an instance declaration.  It notes when the
  215. ;;; context associated with an instance changes.
  216.  
  217. (define (augment-instance-context inst class tyvar)
  218.   (let ((c (instance-context inst)))
  219.     (unless (single-ast-context-implies? c class tyvar)
  220.       (setf *di-context-changed* '#t)
  221.       (setf (instance-context inst)
  222.         (augment-context c class tyvar)))))
  223.  
  224. (define (single-ast-context-implies? ast-context class tyvar)
  225.   (cond ((null? ast-context)
  226.      '#f)
  227.     ((eq? tyvar (context-tyvar (car ast-context)))
  228.      (let ((class1 (class-ref-class (context-class (car ast-context)))))
  229.        (or (eq? class1 class)
  230.            (memq class (class-super* (forward-def class1)))
  231.            (single-ast-context-implies? (cdr ast-context) class tyvar))))
  232.     (else
  233.      (single-ast-context-implies? (cdr ast-context) class tyvar))))
  234.  
  235. ;;; Add class(var) to a context, removing any conte