coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

haskell: reject untypeable programs — hk-typecheck + hk-run-typed (+9 tests, 464/464)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 46s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-05 22:32:18 +00:00
parent 68124adc3b
commit 2606b83920
5 changed files with 121 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

76
lib/haskell/infer.sx
View File

@@ -525,33 +525,37 @@
hk-infer-decl
(fn
(env decl)
(let ((tag (first decl)))
(let
((tag (first decl)))
(cond
((= tag "fun-clause")
(let ((name (nth decl 1))
(pats (nth decl 2))
(body (nth decl 3)))
(let ((rhs (if (empty? pats) body (list "lambda" pats body))))
(guard
(e (#t (list "err" (str "in '" name "': " e))))
(begin
(hk-reset-fresh)
(let ((r (hk-w env rhs)))
(list "ok" name
(hk-type->str (hk-subst-apply (first r) (nth r 1))))))))))
(let
((name (nth decl 1)) (pats (nth decl 2)) (body (nth decl 3)))
(let
((rhs (if (empty? pats) body (list "lambda" pats body))))
(guard
(e (#t (list "err" (str "in '" name "': " e))))
(begin
(hk-reset-fresh)
(let
((r (hk-w env rhs)))
(let
((final-type (hk-subst-apply (first r) (nth r 1))))
(list "ok" name (hk-type->str final-type) final-type))))))))
((or (= tag "bind") (= tag "pat-bind"))
(let ((pat (nth decl 1))
(body (nth decl 2)))
(let ((label (if (and (list? pat) (= (first pat) "p-var"))
(nth pat 1)
"<binding>")))
(guard
(e (#t (list "err" (str "in '" label "': " e))))
(begin
(hk-reset-fresh)
(let ((r (hk-w env body)))
(list "ok" label
(hk-type->str (hk-subst-apply (first r) (nth r 1))))))))))
(let
((pat (nth decl 1)) (body (nth decl 2)))
(let
((label (if (and (list? pat) (= (first pat) "p-var")) (nth pat 1) "<binding>")))
(guard
(e (#t (list "err" (str "in '" label "': " e))))
(begin
(hk-reset-fresh)
(let
((r (hk-w env body)))
(let
((final-type (hk-subst-apply (first r) (nth r 1))))
(list "ok" label (hk-type->str final-type) final-type))))))))
(:else nil)))))
;; hk-infer-prog : program-ast × env → list of ("ok" name type) | ("err" msg)
@@ -560,18 +564,20 @@
hk-infer-prog
(fn
(prog env)
(let ((decls (cond
((and (list? prog) (= (first prog) "program"))
(nth prog 1))
((and (list? prog) (= (first prog) "module"))
(nth prog 3))
(:else (list))))
(results (list)))
(let
((decls (cond ((and (list? prog) (= (first prog) "program")) (nth prog 1)) ((and (list? prog) (= (first prog) "module")) (nth prog 3)) (:else (list))))
(results (list)))
(for-each
(fn (d)
(let ((r (hk-infer-decl env d)))
(when (not (nil? r))
(append! results r))))
(fn
(d)
(let
((r (hk-infer-decl env d)))
(when
(not (nil? r))
(append! results r)
(when
(= (first r) "ok")
(dict-set! env (nth r 1) (nth r 3))))))
decls)
results)))