haskell: case/do + minimal patterns (+19 tests, 119/119)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled

This commit is contained in:
2026-04-24 18:00:58 +00:00
parent 6ccef45ce4
commit 36234f0132
3 changed files with 653 additions and 3 deletions

View File

@@ -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 - ─────────────────────────────────────

View File

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

View File

@@ -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 09, left/right/non assoc, default infixl 9 for