From 60a8eb24e05b95cbe76810199429d0684a240a34 Mon Sep 17 00:00:00 2001
From: giles <giles.bradshaw@rose-ash.com>
Date: Wed, 6 May 2026 08:56:39 +0000
Subject: [PATCH] =?UTF-8?q?haskell:=20dict-passing=20elaborator=20?=
 =?UTF-8?q?=E2=80=94=20runtime=20dispatch=20via=20hk-mk-lazy-builtin=20(+3?=
 =?UTF-8?q?=20tests,=20506/506)?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 lib/haskell/eval.sx        | 79 ++++++++++++++++++++++++++++++++++----
 lib/haskell/tests/class.sx | 25 ++++++++++++
 2 files changed, 97 insertions(+), 7 deletions(-)

diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx
index e159d5b2..8c460b6c 100644
--- a/lib/haskell/eval.sx
+++ b/lib/haskell/eval.sx
@@ -702,10 +702,42 @@ negate x = 0 - x
             ((or (= (first d) "bind") (= (first d) "pat-bind"))
               (append! pat-binds d))
             ((= (first d) "class-decl")
-              (dict-set!
-                env
-                (str "__class__" (nth d 1))
-                (list "class" (nth d 1) (nth d 2))))
+              (let
+                ((cls (nth d 1))
+                  (tvar (nth d 2))
+                  (method-decls (nth d 3)))
+                (dict-set! env (str "__class__" cls) (list "class" cls tvar))
+                (for-each
+                  (fn
+                    (m)
+                    (when
+                      (= (first m) "type-sig")
+                      (for-each
+                        (fn
+                          (mname)
+                          (dict-set!
+                            env
+                            mname
+                            (hk-mk-lazy-builtin
+                              mname
+                              (fn
+                                (x)
+                                (let
+                                  ((tv (hk-force x)))
+                                  (let
+                                    ((key (str "dict" cls "_" (hk-runtime-type tv))))
+                                    (if
+                                      (has-key? env key)
+                                      (hk-apply (get (get env key) mname) x)
+                                      (raise
+                                        (str
+                                          "No instance "
+                                          cls
+                                          " for "
+                                          (hk-runtime-type tv)))))))
+                              1)))
+                        (nth m 1))))
+                  method-decls)))
             ((= (first d) "instance-decl")
               (let
                 ((cls (nth d 1))
@@ -713,8 +745,7 @@ negate x = 0 - x
                   (method-decls (nth d 3)))
                 (let
                   ((inst-dict (dict))
-                    (inst-key
-                      (str "dict" cls "_" (hk-type-ast-str inst-type))))
+                    (type-str (hk-type-ast-str inst-type)))
                   (for-each
                     (fn
                       (m)
@@ -732,7 +763,11 @@ negate x = 0 - x
                               (hk-eval body env)
                               (hk-eval (list "lambda" pats body) env))))))
                     method-decls)
-                  (dict-set! env inst-key inst-dict))))
+                  (dict-set! env (str "dict" cls "_" type-str) inst-dict)
+                  (dict-set!
+                    env
+                    (str "dict" cls "_" (hk-type-to-runtime-key type-str))
+                    inst-dict))))
             (:else nil)))
         decls)
       (let
@@ -829,6 +864,36 @@ negate x = 0 - x
           (hk-type-ast-str (nth ast 2))))
       (:else "?"))))
 
+(define
+  hk-runtime-type
+  (fn
+    (val)
+    (let
+      ((t (type-of val)))
+      (cond
+        ((= t "number") "number")
+        ((= t "boolean") "boolean")
+        ((= t "string") "string")
+        ((and (= t "list") (not (empty? val)))
+          (let
+            ((tag (str (first val))))
+            (cond
+              ((or (= tag "True") (= tag "False")) "Bool")
+              (:else tag))))
+        (:else t)))))
+
+(define
+  hk-type-to-runtime-key
+  (fn
+    (ts)
+    (cond
+      ((= ts "Int") "number")
+      ((= ts "Float") "number")
+      ((= ts "Bool") "Bool")
+      ((= ts "String") "string")
+      ((= ts "Char") "string")
+      (:else ts))))
+
 (define
   hk-typecheck
   (fn
diff --git a/lib/haskell/tests/class.sx b/lib/haskell/tests/class.sx
index b225ee21..f49e5e6e 100644
--- a/lib/haskell/tests/class.sx
+++ b/lib/haskell/tests/class.sx
@@ -32,4 +32,29 @@
   (has-key? (get env-full "dictMyEq_Int") "myEq")
   true)
 
+(hk-test
+  "dispatch: single-arg method works"
+  (hk-deep-force
+    (hk-run
+      "class Describable a where\n  describe :: a -> String\ninstance Describable Int where\n  describe x = \"an integer\"\nmain = describe 42"))
+  "an integer")
+
+(hk-test
+  "dispatch: second instance (Bool)"
+  (hk-deep-force
+    (hk-run
+      "class Describable a where\n  describe :: a -> String\ninstance Describable Bool where\n  describe x = \"a boolean\"\ninstance Describable Int where\n  describe x = \"an integer\"\nmain = describe True"))
+  "a boolean")
+
+(hk-test
+  "dispatch: error on unknown instance"
+  (guard
+    (e (true (>= (index-of e "No instance") 0)))
+    (begin
+      (hk-deep-force
+        (hk-run
+          "class Describable a where\n  describe :: a -> String\nmain = describe 42"))
+      false))
+  true)
+
 {:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
\ No newline at end of file