haskell: value-level pattern matcher (+31 tests, 281/281)

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))))