From 36234f0132c78912a0ebafbcb7c4284c196c2b18 Mon Sep 17 00:00:00 2001
From: giles <giles.bradshaw@rose-ash.com>
Date: Fri, 24 Apr 2026 18:00:58 +0000
Subject: [PATCH] haskell: case/do + minimal patterns (+19 tests, 119/119)

---
 lib/haskell/parser.sx               | 355 +++++++++++++++++++++++++++-
 lib/haskell/tests/parser-case-do.sx | 276 +++++++++++++++++++++
 plans/haskell-on-sx.md              |  25 +-
 3 files changed, 653 insertions(+), 3 deletions(-)
 create mode 100644 lib/haskell/tests/parser-case-do.sx

diff --git a/lib/haskell/parser.sx b/lib/haskell/parser.sx
index ac17898a..8fdbd5ec 100644
--- a/lib/haskell/parser.sx
+++ b/lib/haskell/parser.sx
@@ -95,6 +95,28 @@
           (= ty "lparen")
           (= ty "lbracket"))))))
 
+;; apat-start? — what can begin an atomic pattern
+(define
+  hk-apat-start?
+  (fn
+    (tok)
+    (if
+      (nil? tok)
+      false
+      (let
+        ((ty (get tok "type")))
+        (or
+          (and (= ty "reserved") (= (get tok "value") "_"))
+          (= ty "integer")
+          (= ty "float")
+          (= ty "string")
+          (= ty "char")
+          (= ty "varid")
+          (= ty "conid")
+          (= ty "qconid")
+          (= ty "lparen")
+          (= ty "lbracket"))))))
+
 ;; ── Main entry ───────────────────────────────────────────────────
 (define
   hk-parse-expr
@@ -390,7 +412,336 @@
             (hk-expect! "reservedop" "=")
             (list :bind name (hk-parse-expr-inner)))))
 
-      ;; ── lexp: lambda | if | let | fexp ──────────────────────
+      ;; ── Patterns ─────────────────────────────────────────────
+      (define
+        hk-parse-apat
+        (fn
+          ()
+          (let
+            ((t (hk-peek)))
+            (cond
+              ((nil? t) (hk-err "unexpected end of input in pattern"))
+              ((and
+                  (= (get t "type") "reserved")
+                  (= (get t "value") "_"))
+                (do (hk-advance!) (list :p-wild)))
+              ((= (get t "type") "integer")
+                (do (hk-advance!) (list :p-int (get t "value"))))
+              ((= (get t "type") "float")
+                (do (hk-advance!) (list :p-float (get t "value"))))
+              ((= (get t "type") "string")
+                (do (hk-advance!) (list :p-string (get t "value"))))
+              ((= (get t "type") "char")
+                (do (hk-advance!) (list :p-char (get t "value"))))
+              ((= (get t "type") "varid")
+                (do (hk-advance!) (list :p-var (get t "value"))))
+              ((= (get t "type") "conid")
+                (do
+                  (hk-advance!)
+                  (list :p-con (get t "value") (list))))
+              ((= (get t "type") "qconid")
+                (do
+                  (hk-advance!)
+                  (list :p-con (get t "value") (list))))
+              ((= (get t "type") "lparen") (hk-parse-paren-pat))
+              ((= (get t "type") "lbracket") (hk-parse-list-pat))
+              (:else (hk-err "unexpected token in pattern"))))))
+
+      (define
+        hk-parse-paren-pat
+        (fn
+          ()
+          (hk-expect! "lparen" nil)
+          (cond
+            ((hk-match? "rparen" nil)
+              (do (hk-advance!) (list :p-con "()" (list))))
+            (:else
+              (let
+                ((first-p (hk-parse-pat))
+                  (items (list))
+                  (is-tup false))
+                (append! items first-p)
+                (define
+                  hk-ppt-loop
+                  (fn
+                    ()
+                    (when
+                      (hk-match? "comma" nil)
+                      (do
+                        (hk-advance!)
+                        (set! is-tup true)
+                        (append! items (hk-parse-pat))
+                        (hk-ppt-loop)))))
+                (hk-ppt-loop)
+                (hk-expect! "rparen" nil)
+                (if is-tup (list :p-tuple items) first-p))))))
+
+      (define
+        hk-parse-list-pat
+        (fn
+          ()
+          (hk-expect! "lbracket" nil)
+          (cond
+            ((hk-match? "rbracket" nil)
+              (do (hk-advance!) (list :p-list (list))))
+            (:else
+              (let
+                ((items (list)))
+                (append! items (hk-parse-pat))
+                (define
+                  hk-plt-loop
+                  (fn
+                    ()
+                    (when
+                      (hk-match? "comma" nil)
+                      (do
+                        (hk-advance!)
+                        (append! items (hk-parse-pat))
+                        (hk-plt-loop)))))
+                (hk-plt-loop)
+                (hk-expect! "rbracket" nil)
+                (list :p-list items))))))
+
+      (define
+        hk-parse-pat
+        (fn
+          ()
+          (let
+            ((t (hk-peek)))
+            (cond
+              ((and
+                  (not (nil? t))
+                  (or
+                    (= (get t "type") "conid")
+                    (= (get t "type") "qconid")))
+                (let
+                  ((name (get (hk-advance!) "value")) (args (list)))
+                  (define
+                    hk-pca-loop
+                    (fn
+                      ()
+                      (when
+                        (hk-apat-start? (hk-peek))
+                        (do
+                          (append! args (hk-parse-apat))
+                          (hk-pca-loop)))))
+                  (hk-pca-loop)
+                  (list :p-con name args)))
+              (:else (hk-parse-apat))))))
+
+      ;; ── case ─ of { pat -> expr ; ... } ─────────────────────
+      (define
+        hk-parse-alt
+        (fn
+          ()
+          (let
+            ((pat (hk-parse-pat)))
+            (hk-expect! "reservedop" "->")
+            (list :alt pat (hk-parse-expr-inner)))))
+
+      (define
+        hk-parse-case
+        (fn
+          ()
+          (hk-expect! "reserved" "case")
+          (let
+            ((scrut (hk-parse-expr-inner)))
+            (hk-expect! "reserved" "of")
+            (let
+              ((explicit (hk-match? "lbrace" nil)))
+              (if
+                explicit
+                (hk-advance!)
+                (hk-expect! "vlbrace" nil))
+              (let
+                ((alts (list)))
+                (when
+                  (not
+                    (if
+                      explicit
+                      (hk-match? "rbrace" nil)
+                      (hk-match? "vrbrace" nil)))
+                  (do
+                    (append! alts (hk-parse-alt))
+                    (define
+                      hk-case-loop
+                      (fn
+                        ()
+                        (when
+                          (or
+                            (hk-match? "semi" nil)
+                            (hk-match? "vsemi" nil))
+                          (do
+                            (hk-advance!)
+                            (when
+                              (not
+                                (if
+                                  explicit
+                                  (hk-match? "rbrace" nil)
+                                  (hk-match? "vrbrace" nil)))
+                              (append! alts (hk-parse-alt)))
+                            (hk-case-loop)))))
+                    (hk-case-loop)))
+                (if
+                  explicit
+                  (hk-expect! "rbrace" nil)
+                  (hk-expect! "vrbrace" nil))
+                (list :case scrut alts))))))
+
+      ;; ── do { stmt ; stmt ; ... } ────────────────────────────
+      ;; Scan ahead (respecting paren/bracket/brace depth) for a `<-`
+      ;; before the next `;` / `}` — distinguishes `pat <- e` from a
+      ;; bare expression statement.
+      (define
+        hk-do-stmt-is-bind?
+        (fn
+          ()
+          (let
+            ((j pos) (depth 0) (found false) (done false))
+            (define
+              hk-scan-loop
+              (fn
+                ()
+                (when
+                  (and (not done) (< j n))
+                  (let
+                    ((t (nth toks j)) (ty nil))
+                    (set! ty (get t "type"))
+                    (cond
+                      ((and
+                          (= depth 0)
+                          (or
+                            (= ty "semi")
+                            (= ty "vsemi")
+                            (= ty "rbrace")
+                            (= ty "vrbrace")))
+                        (set! done true))
+                      ((and
+                          (= depth 0)
+                          (= ty "reservedop")
+                          (= (get t "value") "<-"))
+                        (do (set! found true) (set! done true)))
+                      ((or
+                          (= ty "lparen")
+                          (= ty "lbracket")
+                          (= ty "lbrace")
+                          (= ty "vlbrace"))
+                        (set! depth (+ depth 1)))
+                      ((or
+                          (= ty "rparen")
+                          (= ty "rbracket"))
+                        (set! depth (- depth 1)))
+                      (:else nil))
+                    (set! j (+ j 1))
+                    (hk-scan-loop)))))
+            (hk-scan-loop)
+            found)))
+
+      (define
+        hk-parse-do-let
+        (fn
+          ()
+          (hk-expect! "reserved" "let")
+          (let ((explicit (hk-match? "lbrace" nil)))
+            (if
+              explicit
+              (hk-advance!)
+              (hk-expect! "vlbrace" nil))
+            (let
+              ((binds (list)))
+              (when
+                (not
+                  (if
+                    explicit
+                    (hk-match? "rbrace" nil)
+                    (hk-match? "vrbrace" nil)))
+                (do
+                  (append! binds (hk-parse-bind))
+                  (define
+                    hk-dlet-loop
+                    (fn
+                      ()
+                      (when
+                        (or
+                          (hk-match? "semi" nil)
+                          (hk-match? "vsemi" nil))
+                        (do
+                          (hk-advance!)
+                          (when
+                            (not
+                              (if
+                                explicit
+                                (hk-match? "rbrace" nil)
+                                (hk-match? "vrbrace" nil)))
+                            (append! binds (hk-parse-bind)))
+                          (hk-dlet-loop)))))
+                  (hk-dlet-loop)))
+              (if
+                explicit
+                (hk-expect! "rbrace" nil)
+                (hk-expect! "vrbrace" nil))
+              (list :do-let binds)))))
+
+      (define
+        hk-parse-do-stmt
+        (fn
+          ()
+          (cond
+            ((hk-match? "reserved" "let") (hk-parse-do-let))
+            ((hk-do-stmt-is-bind?)
+              (let
+                ((pat (hk-parse-pat)))
+                (hk-expect! "reservedop" "<-")
+                (list :do-bind pat (hk-parse-expr-inner))))
+            (:else (list :do-expr (hk-parse-expr-inner))))))
+
+      (define
+        hk-parse-do
+        (fn
+          ()
+          (hk-expect! "reserved" "do")
+          (let
+            ((explicit (hk-match? "lbrace" nil)))
+            (if
+              explicit
+              (hk-advance!)
+              (hk-expect! "vlbrace" nil))
+            (let
+              ((stmts (list)))
+              (when
+                (not
+                  (if
+                    explicit
+                    (hk-match? "rbrace" nil)
+                    (hk-match? "vrbrace" nil)))
+                (do
+                  (append! stmts (hk-parse-do-stmt))
+                  (define
+                    hk-do-loop
+                    (fn
+                      ()
+                      (when
+                        (or
+                          (hk-match? "semi" nil)
+                          (hk-match? "vsemi" nil))
+                        (do
+                          (hk-advance!)
+                          (when
+                            (not
+                              (if
+                                explicit
+                                (hk-match? "rbrace" nil)
+                                (hk-match? "vrbrace" nil)))
+                            (append! stmts (hk-parse-do-stmt)))
+                          (hk-do-loop)))))
+                  (hk-do-loop)))
+              (if
+                explicit
+                (hk-expect! "rbrace" nil)
+                (hk-expect! "vrbrace" nil))
+              (list :do stmts)))))
+
+      ;; ── lexp: lambda | if | let | case | do | fexp ──────────
       (define
         hk-parse-lexp
         (fn
@@ -399,6 +750,8 @@
             ((hk-match? "reservedop" "\\") (hk-parse-lambda))
             ((hk-match? "reserved" "if") (hk-parse-if))
             ((hk-match? "reserved" "let") (hk-parse-let))
+            ((hk-match? "reserved" "case") (hk-parse-case))
+            ((hk-match? "reserved" "do") (hk-parse-do))
             (:else (hk-parse-fexp)))))
 
       ;; ── Prefix: unary - ─────────────────────────────────────
diff --git a/lib/haskell/tests/parser-case-do.sx b/lib/haskell/tests/parser-case-do.sx
new file mode 100644
index 00000000..658dd3af
--- /dev/null
+++ b/lib/haskell/tests/parser-case-do.sx
@@ -0,0 +1,276 @@
+;; case-of and do-notation parser tests.
+;; Covers the minimal patterns needed to make these meaningful: var,
+;; wildcard, literal, constructor (with and without args), tuple, list.
+
+;; ── Patterns (in case arms) ──
+(hk-test
+  "wildcard pat"
+  (hk-parse "case x of _ -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "var pat"
+  (hk-parse "case x of y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-var "y") (list :var "y")))))
+
+(hk-test
+  "0-arity constructor pat"
+  (hk-parse "case x of\n  Nothing -> 0\n  Just y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0))
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :var "y")))))
+
+(hk-test
+  "int literal pat"
+  (hk-parse "case n of\n  0 -> 1\n  _ -> n")
+  (list
+    :case
+    (list :var "n")
+    (list
+      (list :alt (list :p-int 0) (list :int 1))
+      (list :alt (list :p-wild) (list :var "n")))))
+
+(hk-test
+  "string literal pat"
+  (hk-parse "case s of\n  \"hi\" -> 1\n  _ -> 0")
+  (list
+    :case
+    (list :var "s")
+    (list
+      (list :alt (list :p-string "hi") (list :int 1))
+      (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "tuple pat"
+  (hk-parse "case p of (a, b) -> a")
+  (list
+    :case
+    (list :var "p")
+    (list
+      (list
+        :alt
+        (list
+          :p-tuple
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+(hk-test
+  "list pat"
+  (hk-parse "case xs of\n  [] -> 0\n  [a] -> a")
+  (list
+    :case
+    (list :var "xs")
+    (list
+      (list :alt (list :p-list (list)) (list :int 0))
+      (list
+        :alt
+        (list :p-list (list (list :p-var "a")))
+        (list :var "a")))))
+
+(hk-test
+  "nested constructor pat"
+  (hk-parse "case x of\n  Just (a, b) -> a\n  _ -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          "Just"
+          (list
+            (list
+              :p-tuple
+              (list (list :p-var "a") (list :p-var "b")))))
+        (list :var "a"))
+      (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "constructor with multiple var args"
+  (hk-parse "case t of Pair a b -> a")
+  (list
+    :case
+    (list :var "t")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          "Pair"
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+;; ── case-of shapes ──
+(hk-test
+  "case with explicit braces"
+  (hk-parse "case x of { Just y -> y ; Nothing -> 0 }")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :var "y"))
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
+
+(hk-test
+  "case scrutinee is a full expression"
+  (hk-parse "case f x + 1 of\n  y -> y")
+  (list
+    :case
+    (list
+      :op
+      "+"
+      (list :app (list :var "f") (list :var "x"))
+      (list :int 1))
+    (list (list :alt (list :p-var "y") (list :var "y")))))
+
+(hk-test
+  "case arm body is full expression"
+  (hk-parse "case x of\n  Just y -> y + 1")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :op "+" (list :var "y") (list :int 1))))))
+
+;; ── do blocks ──
+(hk-test
+  "do with two expressions"
+  (hk-parse "do\n  putStrLn \"hi\"\n  return 0")
+  (list
+    :do
+    (list
+      (list
+        :do-expr
+        (list :app (list :var "putStrLn") (list :string "hi")))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :int 0))))))
+
+(hk-test
+  "do with bind"
+  (hk-parse "do\n  x <- getLine\n  putStrLn x")
+  (list
+    :do
+    (list
+      (list :do-bind (list :p-var "x") (list :var "getLine"))
+      (list
+        :do-expr
+        (list :app (list :var "putStrLn") (list :var "x"))))))
+
+(hk-test
+  "do with let"
+  (hk-parse "do\n  let y = 5\n  print y")
+  (list
+    :do
+    (list
+      (list :do-let (list (list :bind "y" (list :int 5))))
+      (list
+        :do-expr
+        (list :app (list :var "print") (list :var "y"))))))
+
+(hk-test
+  "do with multiple let bindings"
+  (hk-parse "do\n  let x = 1\n      y = 2\n  print (x + y)")
+  (list
+    :do
+    (list
+      (list
+        :do-let
+        (list
+          (list :bind "x" (list :int 1))
+          (list :bind "y" (list :int 2))))
+      (list
+        :do-expr
+        (list
+          :app
+          (list :var "print")
+          (list :op "+" (list :var "x") (list :var "y")))))))
+
+(hk-test
+  "do with bind using constructor pat"
+  (hk-parse "do\n  Just x <- getMaybe\n  return x")
+  (list
+    :do
+    (list
+      (list
+        :do-bind
+        (list :p-con "Just" (list (list :p-var "x")))
+        (list :var "getMaybe"))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :var "x"))))))
+
+(hk-test
+  "do with explicit braces"
+  (hk-parse "do { x <- a ; y <- b ; return (x + y) }")
+  (list
+    :do
+    (list
+      (list :do-bind (list :p-var "x") (list :var "a"))
+      (list :do-bind (list :p-var "y") (list :var "b"))
+      (list
+        :do-expr
+        (list
+          :app
+          (list :var "return")
+          (list :op "+" (list :var "x") (list :var "y")))))))
+
+;; ── Mixing case/do inside expressions ──
+(hk-test
+  "case inside let"
+  (hk-parse "let f = \\x -> case x of\n                 Just y -> y\n                 _ -> 0\nin f 5")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        "f"
+        (list
+          :lambda
+          (list "x")
+          (list
+            :case
+            (list :var "x")
+            (list
+              (list
+                :alt
+                (list :p-con "Just" (list (list :p-var "y")))
+                (list :var "y"))
+              (list :alt (list :p-wild) (list :int 0)))))))
+    (list :app (list :var "f") (list :int 5))))
+
+(hk-test
+  "lambda containing do"
+  (hk-parse "\\x -> do\n  y <- x\n  return y")
+  (list
+    :lambda
+    (list "x")
+    (list
+      :do
+      (list
+        (list :do-bind (list :p-var "y") (list :var "x"))
+        (list
+          :do-expr
+          (list :app (list :var "return") (list :var "y")))))))
+
+{: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 ea0142b5..794d82b5 100644
--- a/plans/haskell-on-sx.md
+++ b/plans/haskell-on-sx.md
@@ -58,8 +58,8 @@ Key mappings:
 - [x] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
 - Parser (split into sub-items — implement one per iteration):
   - [x] Expressions: atoms, parens, tuples, lists, ranges, application, infix with full Haskell-98 precedence table, unary `-`, backtick operators, lambdas, `if`, `let`
-  - [ ] `case … of` and `do`-notation expressions
-  - [ ] Patterns (var, wildcard, literal, constructor, as, nested) — consumed by lambdas, let, case, and function clauses
+  - [x] `case … of` and `do`-notation expressions (plus minimal patterns needed for arms/binds: var, wildcard, literal, 0-arity and applied constructor, tuple, list)
+  - [ ] Patterns — full: `as` patterns, nested, negative literal, `~` lazy, extend lambdas/let with non-var patterns
   - [ ] Top-level decls: function clauses, type signatures, `data`, `type`, `newtype`, fixity decls
   - [ ] `where` clauses + guards
   - [ ] Module header + imports (stub)
@@ -114,6 +114,27 @@ Key mappings:
 
 _Newest first._
 
+- **2026-04-24** — Phase 1: `case … of` and `do`-notation parsers. Added `hk-parse-case`
+  / `hk-parse-alt`, `hk-parse-do` / `hk-parse-do-stmt` / `hk-parse-do-let`, plus the
+  minimal pattern language needed to make arms and binds meaningful:
+  `hk-parse-apat` (var, wildcard `_`, int/float/string/char literal, 0-arity
+  conid/qconid, paren+tuple, list) and `hk-parse-pat` (conid applied to
+  apats greedily). AST nodes: `:case SCRUT ALTS`, `:alt PAT BODY`, `:do STMTS`
+  with stmts `:do-expr E` / `:do-bind PAT E` / `:do-let BINDS`, and pattern
+  tags `:p-wild` / `:p-int` / `:p-float` / `:p-string` / `:p-char` / `:p-var`
+  / `:p-con NAME ARGS` / `:p-tuple` / `:p-list`. `do`-stmts disambiguate
+  `pat <- e` vs bare expression with a forward paren/bracket/brace-balanced
+  scan for `<-` before the next `;`/`}` — no backtracking, no AST rewrite.
+  `case` and `do` accept both implicit (`vlbrace`/`vsemi`/`vrbrace`) and
+  explicit braces. Added to `hk-parse-lexp` so they participate fully in
+  operator-precedence expressions. 19 new tests in
+  `lib/haskell/tests/parser-case-do.sx` cover every pattern variant,
+  explicit-brace `case`, expression scrutinees, do with bind/let/expr,
+  multi-binding `let` in `do`, constructor patterns in binds, and
+  `case`/`do` nested inside `let` and lambda. The full pattern item (as
+  patterns, negative literals, `~` lazy, lambda/let pattern extension)
+  remains a separate sub-item. 119/119 green.
+
 - **2026-04-24** — Phase 1: expression parser (`lib/haskell/parser.sx`, ~380 lines).
   Pratt-style precedence climbing against a Haskell-98-default op table (24
   operators across precedence 0–9, left/right/non assoc, default infixl 9 for