rose-ash/lib/haskell/match.sx

;; 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 ────────────────────────────────────────────
;;
;; Pattern match forces the scrutinee to WHNF before inspecting it
;; — except for `p-wild`, `p-var`, and `p-lazy`, which never need
;; to look at the value. Args of constructor / tuple / list values
;; remain thunked (they're forced only when their own pattern needs
;; to inspect them, recursively).
(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-lazy") (hk-match (nth pat 1) val env))
            ((= tag "p-as")
              (let
                ((res (hk-match (nth pat 2) val env)))
                (cond
                  ((nil? res) nil)
                  (:else (assoc res (nth pat 1) val)))))
            (:else
              (let ((fv (hk-force val)))
                (cond
                  ((= tag "p-int")
                    (if
                      (and (number? fv) (= fv (nth pat 1)))
                      env
                      nil))
                  ((= tag "p-float")
                    (if
                      (and (number? fv) (= fv (nth pat 1)))
                      env
                      nil))
                  ((= tag "p-string")
                    (if
                      (and (string? fv) (= fv (nth pat 1)))
                      env
                      nil))
                  ((= tag "p-char")
                    (if
                      (and (string? fv) (= fv (nth pat 1)))
                      env
                      nil))
                  ((= tag "p-con")
                    (let
                      ((pat-name (nth pat 1)) (pat-args (nth pat 2)))
                      (cond
                        ((not (hk-is-con-val? fv)) nil)
                        ((not (= (hk-val-con-name fv) pat-name)) nil)
                        (:else
                          (let
                            ((val-args (hk-val-con-args fv)))
                            (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? fv)) nil)
                        ((not (= (hk-val-con-name fv) "Tuple")) nil)
                        ((not (= (len (hk-val-con-args fv)) (len items)))
                          nil)
                        (:else
                          (hk-match-all
                            items
                            (hk-val-con-args fv)
                            env)))))
                  ((= tag "p-list")
                    (hk-match-list-pat (nth pat 1) fv 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)
    (let ((fv (hk-force val)))
      (cond
        ((empty? items)
          (if
            (and
              (hk-is-con-val? fv)
              (= (hk-val-con-name fv) "[]"))
            env
            nil))
        (:else
          (cond
            ((not (hk-is-con-val? fv)) nil)
            ((not (= (hk-val-con-name fv) ":")) nil)
            (:else
              (let
                ((args (hk-val-con-args fv)))
                (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))))