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

haskell: type error reporting — hk-expr->brief + hk-infer-decl/prog (+21 tests, 455/455)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 48s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-05 21:40:16 +00:00
parent 8f3b0d9301
commit 68124adc3b
4 changed files with 192 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

103
lib/haskell/infer.sx
View File

@@ -431,6 +431,10 @@
elems)
(list s-acc (hk-t-list (hk-subst-apply s-acc tv))))))))
;; Location annotation: just delegate — position is for outer context.
((= tag "loc")
(hk-w env (nth expr 3)))
(:else
(raise (str "hk-w: unhandled tag: " tag)))))))
@@ -472,6 +476,105 @@
(dict-set! env "abs" (hk-tarr hk-t-int hk-t-int))
env)))
;; ─── Expression brief printer ────────────────────────────────────────────────
;; Produces a short human-readable label for an AST node used in error messages.
(define
hk-expr->brief
(fn
(expr)
(cond
((not (list? expr)) (str expr))
((empty? expr) "()")
(:else
(let ((tag (first expr)))
(cond
((= tag "var") (nth expr 1))
((= tag "con") (nth expr 1))
((= tag "int") (str (nth expr 1)))
((= tag "float") (str (nth expr 1)))
((= tag "string") (str "\"" (nth expr 1) "\""))
((= tag "char") (str "'" (nth expr 1) "'"))
((= tag "neg") (str "(-" (hk-expr->brief (nth expr 1)) ")"))
((= tag "app")
(str "(" (hk-expr->brief (nth expr 1))
" " (hk-expr->brief (nth expr 2)) ")"))
((= tag "op")
(str "(" (hk-expr->brief (nth expr 2))
" " (nth expr 1)
" " (hk-expr->brief (nth expr 3)) ")"))
((= tag "lambda") "(\\ ...)")
((= tag "let") "(let ...)")
((= tag "if") "(if ...)")
((= tag "tuple") "(tuple ...)")
((= tag "list") "[...]")
((= tag "loc") (hk-expr->brief (nth expr 3)))
(:else (str "(" tag " ..."))))))))
;; ─── Loc-annotated inference ──────────────────────────────────────────────────
;; ("loc" LINE COL INNER) node: hk-w catches any error and re-raises with
;; "at LINE:COL: " prepended. Emitted by the parser or test scaffolding.
;; Extended hk-w handles "loc" — handled inline in the cond below.
;; ─── Program-level inference ─────────────────────────────────────────────────
;; hk-infer-decl : env × decl → ("ok" name type-str) | ("err" msg) | nil
;; Uses tagged results so callers don't need re-raise.
(define
hk-infer-decl
(fn
(env 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))))))))))
((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))))))))))
(:else nil)))))
;; hk-infer-prog : program-ast × env → list of ("ok" name type) | ("err" msg)
(define
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)))
(for-each
(fn (d)
(let ((r (hk-infer-decl env d)))
(when (not (nil? r))
(append! results r))))
decls)
results)))
;; ─── Convenience ─────────────────────────────────────────────────────────────
;; hk-infer-type : Haskell expression source → inferred type string