From 2efe248224d0b2ab8754974bac49eac2151e8cee Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 18 Oct 2024 10:09:50 -0700 Subject: [PATCH 1/4] fix fundep resolution with superclasses --- src/typechecker/context-reduction.lisp | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/typechecker/context-reduction.lisp b/src/typechecker/context-reduction.lisp index fb4a09f2e..540b95970 100644 --- a/src/typechecker/context-reduction.lisp +++ b/src/typechecker/context-reduction.lisp @@ -268,11 +268,20 @@ Returns (VALUES deferred-preds retained-preds defaultable-preds)" :do (setf subs (compose-substitution-lists subs (fundep-entail% env expr-preds pred known-tyvars))) :finally (return subs))) +(defun expand-pred-into-superclasses (env pred) + (let* ((class (lookup-class env (ty-predicate-class pred))) + (subs (mapcan #'match + (ty-predicate-types (ty-class-predicate class)) + (ty-predicate-types pred)))) + (cons pred (mapcan (lambda (p) (expand-pred-into-superclasses env (apply-substitution subs p))) (ty-class-superclasses class))))) + (defun fundep-entail% (env expr-preds pred known-tyvars) (let ((class (lookup-class env (ty-predicate-class pred)))) (unless (ty-class-fundeps class) (return-from fundep-entail% nil)) + (setf expr-preds (mapcan (lambda (p) (expand-pred-into-superclasses env p)) expr-preds)) + (let* ((unknown-indices nil) (known-indices From f88d05dc50cc3279705315f20608e55718744533 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 18 Oct 2024 10:55:58 -0700 Subject: [PATCH 2/4] added documentation and removed use of mapcan --- src/typechecker/context-reduction.lisp | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/typechecker/context-reduction.lisp b/src/typechecker/context-reduction.lisp index 540b95970..0db61c0f9 100644 --- a/src/typechecker/context-reduction.lisp +++ b/src/typechecker/context-reduction.lisp @@ -269,11 +269,19 @@ Returns (VALUES deferred-preds retained-preds defaultable-preds)" :finally (return subs))) (defun expand-pred-into-superclasses (env pred) + "This function finds the class in ENV associated with PRED and +recursively appends superclass predicates, with appropriate type +substitutions." + (declare (type environment env) + (type ty-predicate pred) + (values ty-predicate-list &optional)) (let* ((class (lookup-class env (ty-predicate-class pred))) (subs (mapcan #'match (ty-predicate-types (ty-class-predicate class)) (ty-predicate-types pred)))) - (cons pred (mapcan (lambda (p) (expand-pred-into-superclasses env (apply-substitution subs p))) (ty-class-superclasses class))))) + (cons pred + (apply #'append (mapcar (lambda (p) (expand-pred-into-superclasses env (apply-substitution subs p))) + (ty-class-superclasses class)))))) (defun fundep-entail% (env expr-preds pred known-tyvars) (let ((class (lookup-class env (ty-predicate-class pred)))) From fb87e950343c682b279c8677ad3f15f56c63b0b5 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 18 Oct 2024 10:56:18 -0700 Subject: [PATCH 3/4] added test for fundep superclass resolution --- tests/fundep-tests.lisp | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/fundep-tests.lisp b/tests/fundep-tests.lisp index 0ebc2fbae..86c09ef65 100644 --- a/tests/fundep-tests.lisp +++ b/tests/fundep-tests.lisp @@ -147,3 +147,19 @@ (let ((filled? (fn (i) (coalton-library/optional:some? (moo-find moo i))))) (coalton-library/iterator:filter! filled? (coalton-library/iterator:up-to (moo-size moo)))))")) + +(deftest fundep-superclass-resolution () + ;; See https://github.com/coalton-lang/coalton/issues/1050 + (check-coalton-types + "(define-class (RandomAccessBase :f :t (:f -> :t)) + (make (UFix -> :t -> :f)) + (rab-length (:f -> UFix))) + + (define-class (RandomAccessBase :f :t => RandomAccessReadable :f :t (:f -> :t)) + (unsafe-set! (:f -> UFix -> :t))) + + (declare aref (RandomAccessReadable :f :t => :f -> UFix -> (Optional :t))) + (define (aref storage index) + (if (and (<= 0 index) (< index (rab-length storage))) + (Some (unsafe-set! storage index)) + None)))")) From 467687c7ce047c2aabfbcda9f49caa9a10a5218d Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 18 Oct 2024 16:19:06 -0700 Subject: [PATCH 4/4] replaced apply append with loop append --- src/typechecker/context-reduction.lisp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/typechecker/context-reduction.lisp b/src/typechecker/context-reduction.lisp index 0db61c0f9..a24322412 100644 --- a/src/typechecker/context-reduction.lisp +++ b/src/typechecker/context-reduction.lisp @@ -279,9 +279,9 @@ substitutions." (subs (mapcan #'match (ty-predicate-types (ty-class-predicate class)) (ty-predicate-types pred)))) - (cons pred - (apply #'append (mapcar (lambda (p) (expand-pred-into-superclasses env (apply-substitution subs p))) - (ty-class-superclasses class)))))) + (cons pred (loop :for super-pred :in (ty-class-superclasses class) + :for corrected-super-pred := (apply-substitution subs super-pred) + :append (expand-pred-into-superclasses env corrected-super-pred))))) (defun fundep-entail% (env expr-preds pred known-tyvars) (let ((class (lookup-class env (ty-predicate-class pred))))