rose-ash/lib/haskell/tests/match.sx

;; 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}