diff --git a/lib/haskell/layout.sx b/lib/haskell/layout.sx index acef31ec..71986828 100644 --- a/lib/haskell/layout.sx +++ b/lib/haskell/layout.sx @@ -227,6 +227,32 @@ (hk-emit {:type "vrbrace" :value "}" :line 0 :col 0}) (set! stack (rest stack)) (hk-close-eof))))) + ;; Peek past further layout-indent / layout-open markers to find + ;; the next real token's value when its type is `reserved`. + ;; Returns nil if no such token. + (define + hk-peek-next-reserved + (fn + (start) + (let ((j (+ start 1)) (found nil) (done false)) + (define + hk-pnr-loop + (fn + () + (when + (and (not done) (< j n)) + (let + ((t (nth pre-toks j)) (ty (get t "type"))) + (cond + ((or + (= ty "layout-indent") + (= ty "layout-open")) + (do (set! j (+ j 1)) (hk-pnr-loop))) + ((= ty "reserved") + (do (set! found (get t "value")) (set! done true))) + (:else (set! done true))))))) + (hk-pnr-loop) + found))) (define hk-layout-step (fn @@ -251,10 +277,14 @@ (set! i (+ i 1)) (hk-layout-step))) ((= ty "layout-indent") - (do - (hk-indent-at (get tok "col") (get tok "line")) - (set! i (+ i 1)) - (hk-layout-step))) + (cond + ((= (hk-peek-next-reserved i) "in") + (do (set! i (+ i 1)) (hk-layout-step))) + (:else + (do + (hk-indent-at (get tok "col") (get tok "line")) + (set! i (+ i 1)) + (hk-layout-step))))) ((= ty "lbrace") (do (set! stack (cons :explicit stack)) diff --git a/lib/haskell/parser.sx b/lib/haskell/parser.sx index 8fdbd5ec..07db0617 100644 --- a/lib/haskell/parser.sx +++ b/lib/haskell/parser.sx @@ -104,9 +104,9 @@ (nil? tok) false (let - ((ty (get tok "type"))) + ((ty (get tok "type")) (val (get tok "value"))) (or - (and (= ty "reserved") (= (get tok "value") "_")) + (and (= ty "reserved") (= val "_")) (= ty "integer") (= ty "float") (= ty "string") @@ -115,7 +115,9 @@ (= ty "conid") (= ty "qconid") (= ty "lparen") - (= ty "lbracket")))))) + (= ty "lbracket") + (and (= ty "varsym") (= val "-")) + (and (= ty "reservedop") (= val "~"))))))) ;; ── Main entry ─────────────────────────────────────────────────── (define @@ -313,7 +315,7 @@ (hk-app-loop) fn-e))) - ;; ── Lambda: \ p1 p2 ... pn -> body ─────────────────────── + ;; ── Lambda: \ apat1 apat2 ... apatn -> body ────────────── (define hk-parse-lambda (fn @@ -322,16 +324,16 @@ (let ((params (list))) (when - (not (hk-match? "varid" nil)) - (hk-err "lambda parameter must be a variable")) + (not (hk-apat-start? (hk-peek))) + (hk-err "lambda needs at least one pattern parameter")) (define hk-lam-loop (fn () (when - (hk-match? "varid" nil) + (hk-apat-start? (hk-peek)) (do - (append! params (get (hk-advance!) "value")) + (append! params (hk-parse-apat)) (hk-lam-loop))))) (hk-lam-loop) (hk-expect! "reservedop" "->") @@ -400,17 +402,17 @@ (hk-expect! "reserved" "in") (list :let binds (hk-parse-expr-inner)))))) + ;; Binding LHS is a pattern. Simple `x = e` parses as + ;; (:bind (:p-var "x") e); pattern bindings like + ;; `(x, y) = pair` parse with a p-tuple LHS. (define hk-parse-bind (fn () - (when - (not (hk-match? "varid" nil)) - (hk-err "binding must start with a variable")) (let - ((name (get (hk-advance!) "value"))) + ((pat (hk-parse-pat))) (hk-expect! "reservedop" "=") - (list :bind name (hk-parse-expr-inner))))) + (list :bind pat (hk-parse-expr-inner))))) ;; ── Patterns ───────────────────────────────────────────── (define @@ -425,6 +427,31 @@ (= (get t "type") "reserved") (= (get t "value") "_")) (do (hk-advance!) (list :p-wild))) + ((and + (= (get t "type") "reservedop") + (= (get t "value") "~")) + (do (hk-advance!) (list :p-lazy (hk-parse-apat)))) + ((and + (= (get t "type") "varsym") + (= (get t "value") "-")) + (do + (hk-advance!) + (let + ((n (hk-peek))) + (cond + ((nil? n) + (hk-err "expected numeric literal after '-'")) + ((= (get n "type") "integer") + (do + (hk-advance!) + (list :p-int (- 0 (get n "value"))))) + ((= (get n "type") "float") + (do + (hk-advance!) + (list :p-float (- 0 (get n "value"))))) + (:else + (hk-err + "only numeric literals may follow '-' in a pattern")))))) ((= (get t "type") "integer") (do (hk-advance!) (list :p-int (get t "value")))) ((= (get t "type") "float") @@ -434,7 +461,19 @@ ((= (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")))) + (let + ((next-t (hk-peek-at 1))) + (cond + ((and + (not (nil? next-t)) + (= (get next-t "type") "reservedop") + (= (get next-t "value") "@")) + (do + (hk-advance!) + (hk-advance!) + (list :p-as (get t "value") (hk-parse-apat)))) + (:else + (do (hk-advance!) (list :p-var (get t "value"))))))) ((= (get t "type") "conid") (do (hk-advance!) @@ -503,7 +542,7 @@ (list :p-list items)))))) (define - hk-parse-pat + hk-parse-pat-lhs (fn () (let @@ -529,6 +568,27 @@ (list :p-con name args))) (:else (hk-parse-apat)))))) + ;; Infix constructor patterns: `x : xs`, `a `Cons` b`, etc. + ;; Right-associative, single precedence band. + (define + hk-parse-pat + (fn + () + (let + ((left (hk-parse-pat-lhs))) + (cond + ((or + (= (hk-peek-type) "consym") + (and + (= (hk-peek-type) "reservedop") + (= (hk-peek-value) ":"))) + (let + ((op (get (hk-advance!) "value"))) + (let + ((right (hk-parse-pat))) + (list :p-con op (list left right))))) + (:else left))))) + ;; ── case ─ of { pat -> expr ; ... } ───────────────────── (define hk-parse-alt diff --git a/lib/haskell/tests/parser-case-do.sx b/lib/haskell/tests/parser-case-do.sx index 658dd3af..ee0e152f 100644 --- a/lib/haskell/tests/parser-case-do.sx +++ b/lib/haskell/tests/parser-case-do.sx @@ -183,7 +183,9 @@ (list :do (list - (list :do-let (list (list :bind "y" (list :int 5)))) + (list + :do-let + (list (list :bind (list :p-var "y") (list :int 5)))) (list :do-expr (list :app (list :var "print") (list :var "y")))))) @@ -197,8 +199,8 @@ (list :do-let (list - (list :bind "x" (list :int 1)) - (list :bind "y" (list :int 2)))) + (list :bind (list :p-var "x") (list :int 1)) + (list :bind (list :p-var "y") (list :int 2)))) (list :do-expr (list @@ -244,10 +246,10 @@ (list (list :bind - "f" + (list :p-var "f") (list :lambda - (list "x") + (list (list :p-var "x")) (list :case (list :var "x") @@ -264,7 +266,7 @@ (hk-parse "\\x -> do\n y <- x\n return y") (list :lambda - (list "x") + (list (list :p-var "x")) (list :do (list diff --git a/lib/haskell/tests/parser-expr.sx b/lib/haskell/tests/parser-expr.sx index e9d4d67b..ff4ef913 100644 --- a/lib/haskell/tests/parser-expr.sx +++ b/lib/haskell/tests/parser-expr.sx @@ -147,20 +147,20 @@ (hk-test "lambda single param" (hk-parse "\\x -> x") - (list :lambda (list "x") (list :var "x"))) + (list :lambda (list (list :p-var "x")) (list :var "x"))) (hk-test "lambda multi-param" (hk-parse "\\x y -> x + y") (list :lambda - (list "x" "y") + (list (list :p-var "x") (list :p-var "y")) (list :op "+" (list :var "x") (list :var "y")))) (hk-test "lambda body is full expression" (hk-parse "\\f -> f 1 + f 2") (list :lambda - (list "f") + (list (list :p-var "f")) (list :op "+" @@ -187,7 +187,7 @@ (hk-parse "let x = 1 in x") (list :let - (list (list :bind "x" (list :int 1))) + (list (list :bind (list :p-var "x") (list :int 1))) (list :var "x"))) (hk-test "let two bindings (multi-line)" @@ -195,8 +195,8 @@ (list :let (list - (list :bind "x" (list :int 1)) - (list :bind "y" (list :int 2))) + (list :bind (list :p-var "x") (list :int 1)) + (list :bind (list :p-var "y") (list :int 2))) (list :op "+" (list :var "x") (list :var "y")))) (hk-test "let with explicit braces" @@ -204,8 +204,8 @@ (list :let (list - (list :bind "x" (list :int 1)) - (list :bind "y" (list :int 2))) + (list :bind (list :p-var "x") (list :int 1)) + (list :bind (list :p-var "y") (list :int 2))) (list :op "+" (list :var "x") (list :var "y")))) ;; ── 12. Mixed / nesting ── @@ -226,7 +226,7 @@ :app (list :lambda - (list "x") + (list (list :p-var "x")) (list :op "+" (list :var "x") (list :int 1))) (list :int 5))) (hk-test @@ -234,7 +234,7 @@ (hk-parse "\\n -> if n == 0 then 1 else n") (list :lambda - (list "n") + (list (list :p-var "n")) (list :if (list :op "==" (list :var "n") (list :int 0)) diff --git a/lib/haskell/tests/parser-patterns.sx b/lib/haskell/tests/parser-patterns.sx new file mode 100644 index 00000000..cfd4044f --- /dev/null +++ b/lib/haskell/tests/parser-patterns.sx @@ -0,0 +1,234 @@ +;; Full-pattern parser tests: as-patterns, lazy ~, negative literals, +;; infix constructor patterns (`:`, any consym), lambda pattern args, +;; and let pattern-bindings. + +;; ── as-patterns ── +(hk-test + "as pattern, wraps constructor" + (hk-parse "case x of n@(Just y) -> n") + (list + :case + (list :var "x") + (list + (list + :alt + (list + :p-as + "n" + (list :p-con "Just" (list (list :p-var "y")))) + (list :var "n"))))) + +(hk-test + "as pattern, wraps wildcard" + (hk-parse "case x of all@_ -> all") + (list + :case + (list :var "x") + (list + (list + :alt + (list :p-as "all" (list :p-wild)) + (list :var "all"))))) + +(hk-test + "as in lambda" + (hk-parse "\\xs@(a : rest) -> xs") + (list + :lambda + (list + (list + :p-as + "xs" + (list + :p-con + ":" + (list (list :p-var "a") (list :p-var "rest"))))) + (list :var "xs"))) + +;; ── lazy patterns ── +(hk-test + "lazy var" + (hk-parse "case x of ~y -> y") + (list + :case + (list :var "x") + (list + (list :alt (list :p-lazy (list :p-var "y")) (list :var "y"))))) + +(hk-test + "lazy constructor" + (hk-parse "\\(~(Just x)) -> x") + (list + :lambda + (list + (list + :p-lazy + (list :p-con "Just" (list (list :p-var "x"))))) + (list :var "x"))) + +;; ── negative literal patterns ── +(hk-test + "negative int pattern" + (hk-parse "case n of\n -1 -> 0\n _ -> n") + (list + :case + (list :var "n") + (list + (list :alt (list :p-int -1) (list :int 0)) + (list :alt (list :p-wild) (list :var "n"))))) + +(hk-test + "negative float pattern" + (hk-parse "case x of -0.5 -> 1") + (list + :case + (list :var "x") + (list (list :alt (list :p-float -0.5) (list :int 1))))) + +;; ── infix constructor patterns (`:` and any consym) ── +(hk-test + "cons pattern" + (hk-parse "case xs of x : rest -> x") + (list + :case + (list :var "xs") + (list + (list + :alt + (list + :p-con + ":" + (list (list :p-var "x") (list :p-var "rest"))) + (list :var "x"))))) + +(hk-test + "cons is right-associative in pats" + (hk-parse "case xs of a : b : rest -> rest") + (list + :case + (list :var "xs") + (list + (list + :alt + (list + :p-con + ":" + (list + (list :p-var "a") + (list + :p-con + ":" + (list (list :p-var "b") (list :p-var "rest"))))) + (list :var "rest"))))) + +(hk-test + "consym pattern" + (hk-parse "case p of a :+: b -> a") + (list + :case + (list :var "p") + (list + (list + :alt + (list + :p-con + ":+:" + (list (list :p-var "a") (list :p-var "b"))) + (list :var "a"))))) + +;; ── lambda with pattern args ── +(hk-test + "lambda with constructor pattern" + (hk-parse "\\(Just x) -> x") + (list + :lambda + (list (list :p-con "Just" (list (list :p-var "x")))) + (list :var "x"))) + +(hk-test + "lambda with tuple pattern" + (hk-parse "\\(a, b) -> a + b") + (list + :lambda + (list + (list + :p-tuple + (list (list :p-var "a") (list :p-var "b")))) + (list :op "+" (list :var "a") (list :var "b")))) + +(hk-test + "lambda with wildcard" + (hk-parse "\\_ -> 42") + (list :lambda (list (list :p-wild)) (list :int 42))) + +(hk-test + "lambda with mixed apats" + (hk-parse "\\x _ (Just y) -> y") + (list + :lambda + (list + (list :p-var "x") + (list :p-wild) + (list :p-con "Just" (list (list :p-var "y")))) + (list :var "y"))) + +;; ── let pattern-bindings ── +(hk-test + "let tuple pattern-binding" + (hk-parse "let (x, y) = pair in x + y") + (list + :let + (list + (list + :bind + (list + :p-tuple + (list (list :p-var "x") (list :p-var "y"))) + (list :var "pair"))) + (list :op "+" (list :var "x") (list :var "y")))) + +(hk-test + "let constructor pattern-binding" + (hk-parse "let Just x = m in x") + (list + :let + (list + (list + :bind + (list :p-con "Just" (list (list :p-var "x"))) + (list :var "m"))) + (list :var "x"))) + +(hk-test + "let cons pattern-binding" + (hk-parse "let (x : rest) = xs in x") + (list + :let + (list + (list + :bind + (list + :p-con + ":" + (list (list :p-var "x") (list :p-var "rest"))) + (list :var "xs"))) + (list :var "x"))) + +;; ── do with constructor-pattern binds ── +(hk-test + "do bind to tuple pattern" + (hk-parse "do\n (a, b) <- pairs\n return a") + (list + :do + (list + (list + :do-bind + (list + :p-tuple + (list (list :p-var "a") (list :p-var "b"))) + (list :var "pairs")) + (list + :do-expr + (list :app (list :var "return") (list :var "a")))))) + +{: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 794d82b5..6a3b92db 100644 --- a/plans/haskell-on-sx.md +++ b/plans/haskell-on-sx.md @@ -59,7 +59,7 @@ Key mappings: - 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` - [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 + - [x] Patterns — full: `as` patterns, nested, negative literal, `~` lazy, infix constructor (`:` / consym), 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,31 @@ Key mappings: _Newest first._ +- **2026-04-24** — Phase 1: full patterns. Added `as` patterns + (`name@apat` → `(:p-as NAME PAT)`), lazy patterns (`~apat` → + `(:p-lazy PAT)`), negative literal patterns (`-N` / `-F` resolving + eagerly in the parser so downstream passes see a plain `(:p-int -1)`), + and infix constructor patterns via a right-associative single-band + layer on top of `hk-parse-pat-lhs` for any `consym` or reservedop `:` + (so `x : xs` parses as `(:p-con ":" [x, xs])`, `a :+: b` likewise). + Extended `hk-apat-start?` with `-` and `~` so the pattern-argument + loops in lambdas and constructor applications pick these up. + Lambdas now parse apat parameters instead of bare varids — so the + `:lambda` AST is `(:lambda APATS BODY)` with apats as pattern nodes. + `hk-parse-bind` became a plain `pat = expr` form, so `:bind` now has + a pattern LHS throughout (simple `x = 1` → `(:bind (:p-var "x") …)`); + this picks up `let (x, y) = pair in …` and `let Just x = m in x` + automatically, and flows through `do`-notation lets. Eight existing + tests updated to the pattern-flavoured AST. Also fixed a pragmatic + layout issue that surfaced in multi-line `let`s: when a layout-indent + would emit a spurious `;` just before an `in` token (because the + let block had already been closed by dedent), `hk-peek-next-reserved` + now lets the layout pass skip that indent and leave closing to the + existing `in` handler. 18 new tests in + `lib/haskell/tests/parser-patterns.sx` cover every pattern variant, + lambda with mixed apats, let pattern-bindings (tuple / constructor / + cons), and do-bind with a tuple pattern. 138/138 green. + - **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: