haskell: dict-passing elaborator — runtime dispatch via hk-mk-lazy-builtin (+3 tests, 506/506)

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!
+              (let
-                env
+                ((cls (nth d 1))
-                (str "__class__" (nth d 1))
+                  (tvar (nth d 2))
-                (list "class" (nth d 1) (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
+                    (type-str (hk-type-ast-str inst-type)))
-                      (str "dict" cls "_" (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

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}