diff options
Diffstat (limited to 'derived/derived-instances.scm')
| -rw-r--r-- | derived/derived-instances.scm | 255 |
1 files changed, 255 insertions, 0 deletions
diff --git a/derived/derived-instances.scm b/derived/derived-instances.scm new file mode 100644 index 0000000..2c65084 --- /dev/null +++ b/derived/derived-instances.scm @@ -0,0 +1,255 @@ + +;;; Basic DI structure: +;;; a. Create the set of instances +;;; b. Expand the context of each potential instance. +;;; c. Once b. reaches a fixpoint, fill in the ast for the generated instances + +(define *di-context-changed* '#f) + +(define (add-derived-instances modules) + (let ((insts '())) + (walk-modules modules + (lambda () (setf insts (append (find-derivable-instances) insts)))) + (compute-di-fixpoint insts) + (dolist (inst insts) + (when (instance-ok? inst) + (create-instance-fns inst) + (push inst (module-instance-defs + (table-entry *modules* + (def-module (instance-algdata inst))))))))) + +(define (compute-di-fixpoint insts) + (setf *di-context-changed* '#f) + (dolist (inst insts) + (propagate-di-context inst)) + (when *di-context-changed* (compute-di-fixpoint insts))) + +;;; Create instance decls for all derived instances in a module. Filter +;;; out underivable instances (Ix & Enum only) + +(define (find-derivable-instances) + (let ((algs (module-alg-defs *module*)) + (insts '())) + (dolist (alg algs) + (dolist (class (algdata-deriving alg)) + (cond ((memq class (list (core-symbol "Eq") + (core-symbol "Ord") + (core-symbol "Text") + (core-symbol "Binary"))) + (setf insts (add-derivable-instance insts alg class '#f))) + ((eq? class *printer-class*) + (setf insts (add-derivable-instance + insts alg (core-symbol "Text") '#t))) + ((eq? class (core-symbol "Ix")) + (if (or (algdata-enum? alg) + (algdata-tuple? alg)) + (setf insts (add-derivable-instance insts alg class '#f)) + (signal-cant-derive-ix alg))) + ((eq? class (core-symbol "Enum")) + (if (algdata-enum? alg) + (setf insts (add-derivable-instance insts alg class '#f)) + (signal-cant-derive-enum alg))) + (else + (signal-not-derivable class))))) + insts)) + + +(define (signal-cant-derive-ix alg) + (phase-error 'cant-derive-IX + "An Ix instance for ~A cannot be derived. It is not an enumeration~%~ + or single-constructor datatype." + alg)) + +(define (signal-cant-derive-enum alg) + (phase-error 'cant-derive-Enum + "An Enum instance for ~A cannot be derived. It is not an enumeration." + alg)) + +(define (signal-not-derivable class) + (recoverable-error 'not-derivable + "Class ~A is not one of the classes that permits derived instances." + class)) + + +;; This adds a provisional instance template. Of course, there may already +;;; be an instance (error!) + +(define (add-derivable-instance insts alg cls sp) + (let ((existing-inst (lookup-instance alg cls))) + (cond ((eq? existing-inst '#f) + (let ((inst (new-instance cls alg (algdata-tyvars alg)))) + (setf (instance-context inst) (algdata-context alg)) + (setf (instance-decls inst) '()) + (setf (instance-ok? inst) '#t) + (setf (instance-suppress-readers? inst) sp) + (cons inst insts))) + (else + (signal-instance-exists alg cls) + insts)))) + +(define (signal-instance-exists alg cls) + (recoverable-error 'instance-exists + "An instance for type ~A in class ~A already exists;~%~ + the deriving clause is being ignored." + alg cls)) + +;;; This updates all instance contexts for an algdata. Each derivable +;;; instance generates a recursive context for every field. If a +;;; component cannot satisfy the desired context, the ok? field is set to +;;; #f to mark the instance as bogus. + +(define (propagate-di-context inst) + (when (instance-ok? inst) + (propagate-constructor-contexts inst + (algdata-constrs (instance-algdata inst))))) + +;;; These two functions propagate the context to ever field of every +;;; constructor + +(define (propagate-constructor-contexts inst constrs) + (or (null? constrs) + (and (propagate-contexts inst (instance-class inst) + (con-types (car constrs))) + (propagate-constructor-contexts inst (cdr constrs))))) + +(define (propagate-contexts inst class types) + (or (null? types) + (and (propagate-type-context inst class (car types)) + (propagate-contexts inst class (cdr types))))) + +;;; This propagates a context out to a given type. The type can only contain +;;; the tyvars which are args to the algdata. + +(define (propagate-type-context inst class type) + (cond ((tyvar? type) + (cond ((single-ast-context-implies? + (instance-context inst) class (tyvar-name type)) + '#t) + (else + (setf *di-context-changed* '#t) + (setf (instance-context inst) + (augment-context (instance-context inst) class + (tyvar-name type))) + '#t))) + ((synonym? (tycon-def type)) + (propagate-type-context inst class (expand-synonym type))) + (else + (let* ((algdata (tycon-def type)) ; must be a algdata + (args (tycon-args type)) + (new-inst (lookup-instance algdata class))) + (cond ((or (eq? new-inst '#f) + (not (instance-ok? new-inst))) + (signal-cannot-derive-instance + (instance-class inst) (instance-algdata inst)) + (setf (instance-ok? inst) '#f) + (setf *di-context-changed* '#t) + '#f) + (else + (propagate-instance-contexts inst + (instance-context new-inst) + (instance-tyvars new-inst) + args))))))) + + +(define (single-ast-context-implies? ast-context class tyvar) + (cond ((null? ast-context) + '#f) + ((eq? tyvar (context-tyvar (car ast-context))) + (let ((class1 (class-ref-class (context-class (car ast-context))))) + (or (eq? class1 class) + (memq class (class-super* class1)) + (single-ast-context-implies? (cdr ast-context) class tyvar)))) + (else + (single-ast-context-implies? (cdr ast-context) class tyvar)))) + +;;; *** This message makes no sense to me. What is the problem that +;;; *** makes it impossible to derive the instance? + +(define (signal-cannot-derive-instance class alg) + (phase-error 'cannot-derive-instance + "Instance ~A(~A) cannot be derived." + class alg)) + + +;;; This propagates contexts into structure components. The context +;;; changes due to the context associated with the various instance +;;; decls encountered. + +;;; Here's the plan for expanding Cls(Alg t1 t2 .. tn) using +;;; instance (Cls1(vx),Cls2(vy),...) => Cls(Alg(v1 v2 .. vn)) +;;; for each Clsx in the instance context, propagate Clsx to the +;;; ti corresponding to vx, where vx must be in the set vi. + +(define (propagate-instance-contexts inst contexts tyvars args) + (or (null? contexts) + (and (propagate-type-context inst + (class-ref-class (context-class (car contexts))) + (find-corresponding-tyvar + (context-tyvar (car contexts)) tyvars args)) + (propagate-instance-contexts inst (cdr contexts) tyvars args)))) + +;;; Given the t(i) and the v(i), return the t corresponding to a v. + +(define (find-corresponding-tyvar tyvar tyvars args) + (if (eq? tyvar (car tyvars)) + (car args) + (find-corresponding-tyvar tyvar (cdr tyvars) (cdr args)))) + +;;; 1 level type synonym expansion + +(define (expand-synonym type) + (let* ((synonym (tycon-def type)) + (args (synonym-args synonym)) + (body (synonym-body synonym))) + (let ((alist (map (lambda (tyvar arg) (tuple tyvar arg)) + args (tycon-args type)))) + (copy-synonym-body body alist)))) + +(define (copy-synonym-body type alist) + (if (tyvar? type) + (tuple-2-2 (assq (tyvar-name type) alist)) + (make tycon (def (tycon-def type)) + (name (tycon-name type)) + (args (map (lambda (ty) + (copy-synonym-body ty alist)) + (tycon-args type)))))) + +;;; This fills in the body decls for an instance function. + +(define (create-instance-fns inst) + (let ((class (instance-class inst)) + (alg (instance-algdata inst))) + (cond ((eq? class (core-symbol "Eq")) + (add-instance inst (eq-fns alg))) + ((eq? class (core-symbol "Ord")) + (add-instance inst (ord-fns alg))) + ((eq? class (core-symbol "Ix")) + (add-instance inst (ix-fns alg))) + ((eq? class (core-symbol "Enum")) + (add-instance inst (enum-fns alg))) + ((eq? class (core-symbol "Text")) + (add-instance inst (text-fns alg (instance-suppress-readers? inst)))) + ((eq? class (core-symbol "Binary")) + (add-instance inst (binary-fns alg)))))) + +(define (add-instance inst decls) + (setf (instance-decls inst) decls)) + +;;; Add class(var) to a context, removing any contexts made redundant by +;;; the new addition. Example: adding Ord a to (Eq a, Eq b) would yield +;;; (Ord a,Eq b). + +(define (augment-context contexts cl var) + (cons (**context (**class/def cl) var) + (remove-implied-contexts cl var contexts))) + +(define (remove-implied-contexts class1 tyvar1 contexts) + (if (null? contexts) + '#f + (with-slots context (class tyvar) (car contexts) + (let ((rest (remove-implied-contexts class1 tyvar1 (cdr contexts))) + (class2 (class-ref-class class))) + (if (and (eq? tyvar1 tyvar) + (memq class2 (class-super* class1))) + rest + (cons (car contexts) rest)))))) |