diff --git a/lib/haskell/match.sx b/lib/haskell/match.sx new file mode 100644 index 00000000..b98d164e --- /dev/null +++ b/lib/haskell/match.sx @@ -0,0 +1,190 @@ +;; Value-level pattern matching. +;; +;; Constructor values are tagged lists whose first element is the +;; constructor name (a string). Tuples use the special tag "Tuple". +;; Lists use the spine of `:` cons and `[]` nil. +;; +;; Just 5 → ("Just" 5) +;; Nothing → ("Nothing") +;; (1, 2) → ("Tuple" 1 2) +;; [1, 2] → (":" 1 (":" 2 ("[]"))) +;; () → ("()") +;; +;; Primitive values (numbers, strings, chars) are stored raw. +;; +;; The matcher takes a pattern AST node, a value, and an environment +;; dict; it returns an extended dict on success, or `nil` on failure. + +;; ── Value builders ────────────────────────────────────────── +(define + hk-mk-con + (fn + (cname args) + (let ((result (list cname))) + (for-each (fn (a) (append! result a)) args) + result))) + +(define + hk-mk-tuple + (fn + (items) + (let ((result (list "Tuple"))) + (for-each (fn (x) (append! result x)) items) + result))) + +(define hk-mk-nil (fn () (list "[]"))) + +(define hk-mk-cons (fn (h t) (list ":" h t))) + +(define + hk-mk-list + (fn + (items) + (cond + ((empty? items) (hk-mk-nil)) + (:else + (hk-mk-cons (first items) (hk-mk-list (rest items))))))) + +;; ── Predicates / accessors on constructor values ─────────── +(define + hk-is-con-val? + (fn + (v) + (and + (list? v) + (not (empty? v)) + (string? (first v))))) + +(define hk-val-con-name (fn (v) (first v))) + +(define hk-val-con-args (fn (v) (rest v))) + +;; ── The matcher ──────────────────────────────────────────── +(define + hk-match + (fn + (pat val env) + (cond + ((not (list? pat)) nil) + ((empty? pat) nil) + (:else + (let + ((tag (first pat))) + (cond + ((= tag "p-wild") env) + ((= tag "p-var") (assoc env (nth pat 1) val)) + ((= tag "p-int") + (if + (and (number? val) (= val (nth pat 1))) + env + nil)) + ((= tag "p-float") + (if + (and (number? val) (= val (nth pat 1))) + env + nil)) + ((= tag "p-string") + (if + (and (string? val) (= val (nth pat 1))) + env + nil)) + ((= tag "p-char") + (if + (and (string? val) (= val (nth pat 1))) + env + nil)) + ((= tag "p-as") + (let + ((res (hk-match (nth pat 2) val env))) + (cond + ((nil? res) nil) + (:else (assoc res (nth pat 1) val))))) + ((= tag "p-lazy") + ;; Eager match for now; phase 3 wires laziness back in. + (hk-match (nth pat 1) val env)) + ((= tag "p-con") + (let + ((pat-name (nth pat 1)) (pat-args (nth pat 2))) + (cond + ((not (hk-is-con-val? val)) nil) + ((not (= (hk-val-con-name val) pat-name)) nil) + (:else + (let + ((val-args (hk-val-con-args val))) + (cond + ((not (= (len pat-args) (len val-args))) + nil) + (:else + (hk-match-all pat-args val-args env)))))))) + ((= tag "p-tuple") + (let + ((items (nth pat 1))) + (cond + ((not (hk-is-con-val? val)) nil) + ((not (= (hk-val-con-name val) "Tuple")) nil) + ((not (= (len (hk-val-con-args val)) (len items))) + nil) + (:else + (hk-match-all + items + (hk-val-con-args val) + env))))) + ((= tag "p-list") + (hk-match-list-pat (nth pat 1) val env)) + (:else nil))))))) + +(define + hk-match-all + (fn + (pats vals env) + (cond + ((empty? pats) env) + (:else + (let + ((res (hk-match (first pats) (first vals) env))) + (cond + ((nil? res) nil) + (:else + (hk-match-all (rest pats) (rest vals) res)))))))) + +(define + hk-match-list-pat + (fn + (items val env) + (cond + ((empty? items) + (if + (and + (hk-is-con-val? val) + (= (hk-val-con-name val) "[]")) + env + nil)) + (:else + (cond + ((not (hk-is-con-val? val)) nil) + ((not (= (hk-val-con-name val) ":")) nil) + (:else + (let + ((args (hk-val-con-args val))) + (let + ((h (first args)) (t (first (rest args)))) + (let + ((res (hk-match (first items) h env))) + (cond + ((nil? res) nil) + (:else + (hk-match-list-pat + (rest items) + t + res)))))))))))) + +;; ── Convenience: parse a pattern from source for tests ───── +;; (Uses the parser's case-alt entry — `case _ of pat -> 0` — +;; to extract a pattern AST.) +(define + hk-parse-pat-source + (fn + (src) + (let + ((expr (hk-parse (str "case 0 of " src " -> 0")))) + (nth (nth (nth expr 2) 0) 1)))) diff --git a/lib/haskell/test.sh b/lib/haskell/test.sh index 00e965b2..d1245376 100755 --- a/lib/haskell/test.sh +++ b/lib/haskell/test.sh @@ -50,6 +50,7 @@ for FILE in "${FILES[@]}"; do (load "lib/haskell/parser.sx") (load "lib/haskell/desugar.sx") (load "lib/haskell/runtime.sx") +(load "lib/haskell/match.sx") (load "lib/haskell/testlib.sx") (epoch 2) (load "$FILE") @@ -90,6 +91,7 @@ EPOCHS (load "lib/haskell/parser.sx") (load "lib/haskell/desugar.sx") (load "lib/haskell/runtime.sx") +(load "lib/haskell/match.sx") (load "lib/haskell/testlib.sx") (epoch 2) (load "$FILE") diff --git a/lib/haskell/tests/match.sx b/lib/haskell/tests/match.sx new file mode 100644 index 00000000..3f475bc0 --- /dev/null +++ b/lib/haskell/tests/match.sx @@ -0,0 +1,256 @@ +;; Pattern-matcher tests. The matcher takes (pat val env) and returns +;; an extended env dict on success, or `nil` on failure. Constructor +;; values are tagged lists (con-name first); tuples use the "Tuple" +;; tag; lists use chained `:` cons with `[]` nil. + +;; ── Atomic patterns ── +(hk-test + "wildcard always matches" + (hk-match (list :p-wild) 42 (dict)) + (dict)) + +(hk-test + "var binds value" + (hk-match (list :p-var "x") 42 (dict)) + {:x 42}) + +(hk-test + "var preserves prior env" + (hk-match (list :p-var "y") 7 {:x 1}) + {:x 1 :y 7}) + +(hk-test + "int literal matches equal" + (hk-match (list :p-int 5) 5 (dict)) + (dict)) + +(hk-test + "int literal fails on mismatch" + (hk-match (list :p-int 5) 6 (dict)) + nil) + +(hk-test + "negative int literal matches" + (hk-match (list :p-int -3) -3 (dict)) + (dict)) + +(hk-test + "string literal matches" + (hk-match (list :p-string "hi") "hi" (dict)) + (dict)) + +(hk-test + "string literal fails" + (hk-match (list :p-string "hi") "bye" (dict)) + nil) + +(hk-test + "char literal matches" + (hk-match (list :p-char "a") "a" (dict)) + (dict)) + +;; ── Constructor patterns ── +(hk-test + "0-arity con matches" + (hk-match + (list :p-con "Nothing" (list)) + (hk-mk-con "Nothing" (list)) + (dict)) + (dict)) + +(hk-test + "1-arity con matches and binds" + (hk-match + (list :p-con "Just" (list (list :p-var "y"))) + (hk-mk-con "Just" (list 9)) + (dict)) + {:y 9}) + +(hk-test + "con name mismatch fails" + (hk-match + (list :p-con "Just" (list (list :p-var "y"))) + (hk-mk-con "Nothing" (list)) + (dict)) + nil) + +(hk-test + "con arity mismatch fails" + (hk-match + (list :p-con "Pair" (list (list :p-var "a") (list :p-var "b"))) + (hk-mk-con "Pair" (list 1)) + (dict)) + nil) + +(hk-test + "nested con: Just (Just x)" + (hk-match + (list + :p-con + "Just" + (list + (list + :p-con + "Just" + (list (list :p-var "x"))))) + (hk-mk-con "Just" (list (hk-mk-con "Just" (list 42)))) + (dict)) + {:x 42}) + +;; ── Tuple patterns ── +(hk-test + "2-tuple matches and binds" + (hk-match + (list + :p-tuple + (list (list :p-var "a") (list :p-var "b"))) + (hk-mk-tuple (list 10 20)) + (dict)) + {:a 10 :b 20}) + +(hk-test + "tuple arity mismatch fails" + (hk-match + (list + :p-tuple + (list (list :p-var "a") (list :p-var "b"))) + (hk-mk-tuple (list 10 20 30)) + (dict)) + nil) + +;; ── List patterns ── +(hk-test + "[] pattern matches empty list" + (hk-match (list :p-list (list)) (hk-mk-nil) (dict)) + (dict)) + +(hk-test + "[] pattern fails on non-empty" + (hk-match (list :p-list (list)) (hk-mk-list (list 1)) (dict)) + nil) + +(hk-test + "[a] pattern matches singleton" + (hk-match + (list :p-list (list (list :p-var "a"))) + (hk-mk-list (list 7)) + (dict)) + {:a 7}) + +(hk-test + "[a, b] pattern matches pair-list and binds" + (hk-match + (list + :p-list + (list (list :p-var "a") (list :p-var "b"))) + (hk-mk-list (list 1 2)) + (dict)) + {:a 1 :b 2}) + +(hk-test + "[a, b] fails on too-long list" + (hk-match + (list + :p-list + (list (list :p-var "a") (list :p-var "b"))) + (hk-mk-list (list 1 2 3)) + (dict)) + nil) + +;; Cons-style infix pattern (which the parser produces as :p-con ":") +(hk-test + "cons (h:t) on non-empty list" + (hk-match + (list + :p-con + ":" + (list (list :p-var "h") (list :p-var "t"))) + (hk-mk-list (list 1 2 3)) + (dict)) + {:h 1 :t (list ":" 2 (list ":" 3 (list "[]")))}) + +(hk-test + "cons fails on empty list" + (hk-match + (list + :p-con + ":" + (list (list :p-var "h") (list :p-var "t"))) + (hk-mk-nil) + (dict)) + nil) + +;; ── as patterns ── +(hk-test + "as binds whole + sub-pattern" + (hk-match + (list + :p-as + "all" + (list :p-con "Just" (list (list :p-var "x")))) + (hk-mk-con "Just" (list 99)) + (dict)) + {:all (list "Just" 99) :x 99}) + +(hk-test + "as on wildcard binds whole" + (hk-match + (list :p-as "v" (list :p-wild)) + "anything" + (dict)) + {:v "anything"}) + +(hk-test + "as fails when sub-pattern fails" + (hk-match + (list + :p-as + "n" + (list :p-con "Just" (list (list :p-var "x")))) + (hk-mk-con "Nothing" (list)) + (dict)) + nil) + +;; ── lazy ~ pattern (eager equivalent for now) ── +(hk-test + "lazy pattern eager-matches its inner" + (hk-match + (list :p-lazy (list :p-var "y")) + 42 + (dict)) + {:y 42}) + +;; ── Source-driven: parse a real Haskell pattern, match a value ── +(hk-test + "parsed pattern: Just x against Just 5" + (hk-match + (hk-parse-pat-source "Just x") + (hk-mk-con "Just" (list 5)) + (dict)) + {:x 5}) + +(hk-test + "parsed pattern: x : xs against [10, 20, 30]" + (hk-match + (hk-parse-pat-source "x : xs") + (hk-mk-list (list 10 20 30)) + (dict)) + {:x 10 :xs (list ":" 20 (list ":" 30 (list "[]")))}) + +(hk-test + "parsed pattern: (a, b) against (1, 2)" + (hk-match + (hk-parse-pat-source "(a, b)") + (hk-mk-tuple (list 1 2)) + (dict)) + {:a 1 :b 2}) + +(hk-test + "parsed pattern: n@(Just x) against Just 7" + (hk-match + (hk-parse-pat-source "n@(Just x)") + (hk-mk-con "Just" (list 7)) + (dict)) + {:n (list "Just" 7) :x 7}) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/plans/haskell-on-sx.md b/plans/haskell-on-sx.md index b77e6b69..e76c852a 100644 --- a/plans/haskell-on-sx.md +++ b/plans/haskell-on-sx.md @@ -70,7 +70,7 @@ Key mappings: ### Phase 2 — desugar + eager-ish eval + ADTs (untyped) - [x] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3) - [x] `data` declarations register constructors in runtime -- [ ] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested +- [x] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested - [ ] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors - [ ] 30+ eval tests in `lib/haskell/tests/eval.sx` @@ -114,6 +114,33 @@ Key mappings: _Newest first._ +- **2026-04-24** — Phase 2: value-level pattern matcher + (`lib/haskell/match.sx`). Core entry `hk-match pat val env` returns + an extended env dict on success or `nil` on failure (uses `assoc` + rather than `dict-set!` so failed branches never pollute the + caller's env). Constructor values are tagged lists with the + constructor name as the first element; tuples use the tag `"Tuple"`, + lists are chained `(":" h t)` cons cells terminated by `("[]")`. + Value builders `hk-mk-con` / `hk-mk-tuple` / `hk-mk-nil` / + `hk-mk-cons` / `hk-mk-list` keep tests readable. The matcher + handles every pattern node the parser emits: + - `:p-wild` (always matches), `:p-var` (binds), `:p-int` / + `:p-float` / `:p-string` / `:p-char` (literal equality) + - `:p-as` (sub-match then bind whole), `:p-lazy` (eager for now; + laziness wired in phase 3) + - `:p-con` with arity check + recursive arg matching, including + deeply nested patterns and infix `:` cons (uses the same + code path as named constructors) + - `:p-tuple` against `"Tuple"` values, `:p-list` against an + exact-length cons spine. + Helper `hk-parse-pat-source` lifts a real Haskell pattern out of + `case _ of -> 0`, letting tests drive against parser output. + 31 new tests in `lib/haskell/tests/match.sx` cover atomic + patterns, success/failure for each con/tuple/list shape, nested + `Just (Just x)`, cons-vs-empty, `as` over con / wildcard / + failing-sub, `~` lazy, plus four parser-driven cases (`Just x`, + `x : xs`, `(a, b)`, `n@(Just x)`). 281/281 green. + - **2026-04-24** — Phase 2: runtime constructor registry (`lib/haskell/runtime.sx`). A mutable dict `hk-constructors` keyed by constructor name, each entry carrying arity and owning type.