diff --git a/lib/haskell/infer.sx b/lib/haskell/infer.sx index 992c264b..4f290f28 100644 --- a/lib/haskell/infer.sx +++ b/lib/haskell/infer.sx @@ -560,13 +560,76 @@ ;; hk-infer-prog : program-ast × env → list of ("ok" name type) | ("err" msg) +(define + hk-ast-type + (fn + (ast) + (let + ((tag (first ast))) + (cond + ((= tag "t-con") (list "TCon" (nth ast 1))) + ((= tag "t-var") (list "TVar" (nth ast 1))) + ((= tag "t-fun") + (list "TArr" (hk-ast-type (nth ast 1)) (hk-ast-type (nth ast 2)))) + ((= tag "t-app") + (list "TApp" (hk-ast-type (nth ast 1)) (hk-ast-type (nth ast 2)))) + ((= tag "t-list") + (list "TApp" (list "TCon" "[]") (hk-ast-type (nth ast 1)))) + ((= tag "t-tuple") (list "TTuple" (map hk-ast-type (nth ast 1)))) + (:else (raise (str "unknown type node: " (first ast)))))))) + +;; ─── Convenience ───────────────────────────────────────────────────────────── +;; hk-infer-type : Haskell expression source → inferred type string + +(define + hk-collect-tvars + (fn + (t acc) + (cond + ((= (first t) "TVar") + (if + (some (fn (v) (= v (nth t 1))) acc) + acc + (begin (append! acc (nth t 1)) acc))) + ((= (first t) "TArr") + (hk-collect-tvars (nth t 2) (hk-collect-tvars (nth t 1) acc))) + ((= (first t) "TApp") + (hk-collect-tvars (nth t 2) (hk-collect-tvars (nth t 1) acc))) + ((= (first t) "TTuple") + (reduce (fn (a elem) (hk-collect-tvars elem a)) acc (nth t 1))) + (:else acc)))) + +(define + hk-check-sig + (fn + (declared-ast inferred-type) + (let + ((declared (hk-ast-type declared-ast))) + (let + ((tvars (hk-collect-tvars declared (list)))) + (let + ((scheme (if (empty? tvars) declared (list "TScheme" tvars declared)))) + (let + ((inst (hk-instantiate scheme))) + (hk-unify inst inferred-type))))))) + (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))) + (results (list)) + (sigs (dict))) + (for-each + (fn + (d) + (when + (= (first d) "type-sig") + (let + ((names (nth d 1)) (type-ast (nth d 2))) + (for-each (fn (n) (dict-set! sigs n type-ast)) names)))) + decls) (for-each (fn (d) @@ -574,22 +637,22 @@ ((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)))))) + (let + ((checked (if (and (= (first r) "ok") (has-key? sigs (nth r 1))) (guard (e (true (list "err" (str "in '" (nth r 1) "': declared type mismatch: " e)))) (begin (hk-check-sig (get sigs (nth r 1)) (nth r 3)) r)) r))) + (append! results checked) + (when + (= (first checked) "ok") + (dict-set! env (nth checked 1) (nth checked 3))))))) decls) results))) -;; ─── Convenience ───────────────────────────────────────────────────────────── -;; hk-infer-type : Haskell expression source → inferred type string - (define hk-infer-type (fn (src) (hk-reset-fresh) - (let ((ast (hk-core-expr src)) - (env (hk-type-env0))) - (let ((r (hk-w env ast))) + (let + ((ast (hk-core-expr src)) (env (hk-type-env0))) + (let + ((r (hk-w env ast))) (hk-type->str (hk-subst-apply (first r) (nth r 1))))))) diff --git a/lib/haskell/tests/typecheck.sx b/lib/haskell/tests/typecheck.sx index ea2c14c4..6f46e089 100644 --- a/lib/haskell/tests/typecheck.sx +++ b/lib/haskell/tests/typecheck.sx @@ -41,4 +41,42 @@ ;; Function body type error: applying non-function. (hk-tc-err "reject: apply non-function" "f x = 1 x" "Int") +(define prog-sig1 (hk-core "f :: Int -> Int\nf x = x + 1")) + +(define prog-sig2 (hk-core "f :: Bool -> Bool\nf x = x + 1")) + +(define prog-sig3 (hk-core "id :: a -> a\nid x = x")) + +(hk-test + "sig ok: Int->Int accepted" + (first (nth (hk-infer-prog prog-sig1 (hk-type-env0)) 0)) + "ok") + +(hk-test + "sig fail: Bool->Bool rejected" + (first (nth (hk-infer-prog prog-sig2 (hk-type-env0)) 0)) + "err") + +(hk-test + "sig fail: error mentions mismatch" + (hk-str-has? + (nth (nth (hk-infer-prog prog-sig2 (hk-type-env0)) 0) 1) + "mismatch") + true) + +(hk-test + "sig ok: polymorphic a->a accepted" + (first (nth (hk-infer-prog prog-sig3 (hk-type-env0)) 0)) + "ok") + +(hk-tc-err + "run-typed sig fail: Bool declared, Int inferred" + "main :: Bool\nmain = 1 + 2" + "mismatch") + +(hk-test + "run-typed sig ok: Int declared matches" + (hk-run-typed "main :: Int\nmain = 1 + 2") + 3) + {:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} \ No newline at end of file diff --git a/plans/haskell-on-sx.md b/plans/haskell-on-sx.md index 4a012398..d3238167 100644 --- a/plans/haskell-on-sx.md +++ b/plans/haskell-on-sx.md @@ -94,7 +94,7 @@ Key mappings: - [x] Algorithm W: unification + type schemes + generalisation + instantiation - [x] Report type errors with meaningful positions - [x] Reject untypeable programs that phase 3 was accepting -- [ ] Type-sig checking: user writes `f :: Int -> Int`; verify +- [x] Type-sig checking: user writes `f :: Int -> Int`; verify - [ ] Let-polymorphism - [ ] Unit tests: inference for 50+ expressions @@ -114,6 +114,17 @@ Key mappings: _Newest first._ +- **2026-05-05** — Phase 4 type-sig checking. `hk-ast-type` converts parsed type + AST nodes (`t-con`/`t-var`/`t-fun`/`t-app`/`t-list`/`t-tuple`) to internal + type values. `hk-collect-tvars` gathers free type variable names. `hk-check-sig` + wraps declared type in a scheme (if polymorphic), instantiates with fresh vars, + and unifies against the inferred type. `hk-infer-prog` updated: first pass + collects `type-sig` declarations into a `sigs` dict; second pass checks each + successful fun-clause inference against its declared sig, returning + `("err" "... declared type mismatch: ...")` on mismatch. 6 new tests in + `typecheck.sx` cover monomorphic sig match, sig mismatch (error message), + polymorphic `a->a` sig, and `hk-run-typed` with and without sig. 470/470 green. + - **2026-05-05** — Phase 4 reject untypeable programs. `hk-typecheck` runs `hk-infer-prog` on a program AST and raises the first type error found. `hk-run-typed` is a drop-in for `hk-run` that gates evaluation on a