diff --git a/lib/haskell/parser.sx b/lib/haskell/parser.sx index 1b442e2d..07c8cc0b 100644 --- a/lib/haskell/parser.sx +++ b/lib/haskell/parser.sx @@ -419,17 +419,141 @@ (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. + ;; ── RHS: guards + optional where ───────────────────────── + ;; A rhs is either a plain body after `=`/`->`, or a list of + ;; guarded bodies (`| cond = e | cond = e …`), optionally + ;; followed by a `where` block of local decls. Shapes: + ;; plain: + ;; guards: (:guarded ((:guard C1 E1) (:guard C2 E2) …)) + ;; where: (:where DECLS) + ;; Used by fun-clauses, let/do-let bindings, and case alts. + (define + hk-parse-where-decls + (fn + () + (let ((explicit (hk-match? "lbrace" nil))) + (if + explicit + (hk-advance!) + (hk-expect! "vlbrace" nil)) + (let ((decls (list))) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (do + (append! decls (hk-parse-decl)) + (define + hk-wd-loop + (fn + () + (when + (or + (hk-match? "vsemi" nil) + (hk-match? "semi" nil)) + (do + (hk-advance!) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (append! decls (hk-parse-decl))) + (hk-wd-loop))))) + (hk-wd-loop))) + (if + explicit + (hk-expect! "rbrace" nil) + (hk-expect! "vrbrace" nil)) + decls)))) + + (define + hk-parse-guarded + (fn + (sep) + (let ((guards (list))) + (define + hk-g-loop + (fn + () + (when + (hk-match? "reservedop" "|") + (do + (hk-advance!) + (let + ((cond-e (hk-parse-expr-inner))) + (hk-expect! "reservedop" sep) + (let + ((expr-e (hk-parse-expr-inner))) + (append! guards (list :guard cond-e expr-e)) + (hk-g-loop))))))) + (hk-g-loop) + (list :guarded guards)))) + + (define + hk-parse-rhs + (fn + (sep) + (let + ((body + (cond + ((hk-match? "reservedop" "|") + (hk-parse-guarded sep)) + (:else + (do + (hk-expect! "reservedop" sep) + (hk-parse-expr-inner)))))) + (cond + ((hk-match? "reserved" "where") + (do + (hk-advance!) + (list :where body (hk-parse-where-decls)))) + (:else body))))) + + ;; Binding LHS is a pattern (for pat-binds), a varid alone + ;; (simple `x = e`), or a varid followed by apats (the + ;; `let f x = …` / `let f x | g = … | g = …` funclause form). (define hk-parse-bind (fn () (let - ((pat (hk-parse-pat))) - (hk-expect! "reservedop" "=") - (list :bind pat (hk-parse-expr-inner))))) + ((t (hk-peek))) + (cond + ((and + (not (nil? t)) + (= (get t "type") "varid")) + (let + ((name (get (hk-advance!) "value")) + (pats (list))) + (define + hk-b-loop + (fn + () + (when + (hk-apat-start? (hk-peek)) + (do + (append! pats (hk-parse-apat)) + (hk-b-loop))))) + (hk-b-loop) + (if + (= (len pats) 0) + (list + :bind + (list :p-var name) + (hk-parse-rhs "=")) + (list + :fun-clause + name + pats + (hk-parse-rhs "="))))) + (:else + (let + ((pat (hk-parse-pat))) + (list :bind pat (hk-parse-rhs "=")))))))) ;; ── Patterns ───────────────────────────────────────────── (define @@ -613,8 +737,7 @@ () (let ((pat (hk-parse-pat))) - (hk-expect! "reservedop" "->") - (list :alt pat (hk-parse-expr-inner))))) + (list :alt pat (hk-parse-rhs "->"))))) (define hk-parse-case @@ -1120,13 +1243,11 @@ (append! pats (hk-parse-apat)) (hk-fc-loop))))) (hk-fc-loop) - (hk-expect! "reservedop" "=") - (list :fun-clause name pats (hk-parse-expr-inner)))) + (list :fun-clause name pats (hk-parse-rhs "=")))) (:else (let ((pat (hk-parse-pat))) - (hk-expect! "reservedop" "=") - (list :pat-bind pat (hk-parse-expr-inner)))))))) + (list :pat-bind pat (hk-parse-rhs "=")))))))) (define hk-parse-con-def diff --git a/lib/haskell/tests/parser-guards-where.sx b/lib/haskell/tests/parser-guards-where.sx new file mode 100644 index 00000000..ab41eb9c --- /dev/null +++ b/lib/haskell/tests/parser-guards-where.sx @@ -0,0 +1,261 @@ +;; Guards and where-clauses — on fun-clauses, case alts, and +;; let-bindings (which now also accept funclause-style LHS like +;; `let f x = e` or `let f x | g = e | g = e`). + +(define + hk-prog + (fn (&rest decls) (list :program decls))) + +;; ── Guarded fun-clauses ── +(hk-test + "simple guards (two branches)" + (hk-parse-top "abs x | x < 0 = - x\n | otherwise = x") + (hk-prog + (list + :fun-clause + "abs" + (list (list :p-var "x")) + (list + :guarded + (list + (list + :guard + (list :op "<" (list :var "x") (list :int 0)) + (list :neg (list :var "x"))) + (list :guard (list :var "otherwise") (list :var "x"))))))) + +(hk-test + "three-way guard" + (hk-parse-top "sign n | n > 0 = 1\n | n < 0 = -1\n | otherwise = 0") + (hk-prog + (list + :fun-clause + "sign" + (list (list :p-var "n")) + (list + :guarded + (list + (list + :guard + (list :op ">" (list :var "n") (list :int 0)) + (list :int 1)) + (list + :guard + (list :op "<" (list :var "n") (list :int 0)) + (list :neg (list :int 1))) + (list + :guard + (list :var "otherwise") + (list :int 0))))))) + +(hk-test + "mixed: one eq clause plus one guarded clause" + (hk-parse-top "sign 0 = 0\nsign n | n > 0 = 1\n | otherwise = -1") + (hk-prog + (list + :fun-clause + "sign" + (list (list :p-int 0)) + (list :int 0)) + (list + :fun-clause + "sign" + (list (list :p-var "n")) + (list + :guarded + (list + (list + :guard + (list :op ">" (list :var "n") (list :int 0)) + (list :int 1)) + (list + :guard + (list :var "otherwise") + (list :neg (list :int 1)))))))) + +;; ── where on fun-clauses ── +(hk-test + "where with one binding" + (hk-parse-top "f x = y + y\n where y = x + 1") + (hk-prog + (list + :fun-clause + "f" + (list (list :p-var "x")) + (list + :where + (list :op "+" (list :var "y") (list :var "y")) + (list + (list + :fun-clause + "y" + (list) + (list :op "+" (list :var "x") (list :int 1)))))))) + +(hk-test + "where with multiple bindings" + (hk-parse-top "f x = y * z\n where y = x + 1\n z = x - 1") + (hk-prog + (list + :fun-clause + "f" + (list (list :p-var "x")) + (list + :where + (list :op "*" (list :var "y") (list :var "z")) + (list + (list + :fun-clause + "y" + (list) + (list :op "+" (list :var "x") (list :int 1))) + (list + :fun-clause + "z" + (list) + (list :op "-" (list :var "x") (list :int 1)))))))) + +(hk-test + "guards + where" + (hk-parse-top "f x | x > 0 = y\n | otherwise = 0\n where y = 99") + (hk-prog + (list + :fun-clause + "f" + (list (list :p-var "x")) + (list + :where + (list + :guarded + (list + (list + :guard + (list :op ">" (list :var "x") (list :int 0)) + (list :var "y")) + (list + :guard + (list :var "otherwise") + (list :int 0)))) + (list + (list :fun-clause "y" (list) (list :int 99))))))) + +;; ── Guards in case alts ── +(hk-test + "case alt with guards" + (hk-parse "case x of\n Just y | y > 0 -> y\n | otherwise -> 0\n Nothing -> 0") + (list + :case + (list :var "x") + (list + (list + :alt + (list :p-con "Just" (list (list :p-var "y"))) + (list + :guarded + (list + (list + :guard + (list :op ">" (list :var "y") (list :int 0)) + (list :var "y")) + (list + :guard + (list :var "otherwise") + (list :int 0))))) + (list :alt (list :p-con "Nothing" (list)) (list :int 0))))) + +(hk-test + "case alt with where" + (hk-parse "case x of\n Just y -> y + z where z = 5\n Nothing -> 0") + (list + :case + (list :var "x") + (list + (list + :alt + (list :p-con "Just" (list (list :p-var "y"))) + (list + :where + (list :op "+" (list :var "y") (list :var "z")) + (list + (list :fun-clause "z" (list) (list :int 5))))) + (list :alt (list :p-con "Nothing" (list)) (list :int 0))))) + +;; ── let-bindings: funclause form, guards, where ── +(hk-test + "let with funclause shorthand" + (hk-parse "let f x = x + 1 in f 5") + (list + :let + (list + (list + :fun-clause + "f" + (list (list :p-var "x")) + (list :op "+" (list :var "x") (list :int 1)))) + (list :app (list :var "f") (list :int 5)))) + +(hk-test + "let with guards" + (hk-parse "let f x | x > 0 = x\n | otherwise = 0\nin f 3") + (list + :let + (list + (list + :fun-clause + "f" + (list (list :p-var "x")) + (list + :guarded + (list + (list + :guard + (list :op ">" (list :var "x") (list :int 0)) + (list :var "x")) + (list + :guard + (list :var "otherwise") + (list :int 0)))))) + (list :app (list :var "f") (list :int 3)))) + +(hk-test + "let funclause + where" + (hk-parse "let f x = y where y = x + 1\nin f 7") + (list + :let + (list + (list + :fun-clause + "f" + (list (list :p-var "x")) + (list + :where + (list :var "y") + (list + (list + :fun-clause + "y" + (list) + (list :op "+" (list :var "x") (list :int 1))))))) + (list :app (list :var "f") (list :int 7)))) + +;; ── Nested: where inside where (via recursive hk-parse-decl) ── +(hk-test + "where block can contain a type signature" + (hk-parse-top "f x = y\n where y :: Int\n y = x") + (hk-prog + (list + :fun-clause + "f" + (list (list :p-var "x")) + (list + :where + (list :var "y") + (list + (list :type-sig (list "y") (list :t-con "Int")) + (list + :fun-clause + "y" + (list) + (list :var "x"))))))) + +{: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 528a286e..ae1e59eb 100644 --- a/plans/haskell-on-sx.md +++ b/plans/haskell-on-sx.md @@ -61,7 +61,7 @@ Key mappings: - [x] `case … of` and `do`-notation expressions (plus minimal patterns needed for arms/binds: var, wildcard, literal, 0-arity and applied constructor, tuple, list) - [x] Patterns — full: `as` patterns, nested, negative literal, `~` lazy, infix constructor (`:` / consym), extend lambdas/let with non-var patterns - [x] Top-level decls: function clauses (simple — no guards/where yet), pattern bindings, multi-name type signatures, `data` with type vars and recursive constructors, `type` synonyms, `newtype`, fixity (`infix`/`infixl`/`infixr` with optional precedence, comma-separated ops, backtick names). Types: vars / constructors / application / `->` (right-assoc) / tuples / lists. `hk-parse-top` entry. - - [ ] `where` clauses + guards + - [x] `where` clauses + guards (on fun-clauses, case alts, and let/do-let bindings — with the let funclause shorthand `let f x = …` now supported) - [ ] Module header + imports (stub) - [ ] List comprehensions + operator sections - [ ] AST design modelled on GHC's HsSyn at a surface level @@ -114,6 +114,28 @@ Key mappings: _Newest first._ +- **2026-04-24** — Phase 1: guards + where clauses. Factored a single + `hk-parse-rhs sep` that all body-producing sites now share: it reads + a plain `sep expr` body or a chain of `| cond sep expr` guards, then + — regardless of which form — looks for an optional `where` block and + wraps accordingly. AST additions: + - `:guarded GUARDS` where each GUARD is `:guard COND EXPR` + - `:where BODY DECLS` where BODY is a plain expr or a `:guarded` + Both can nest (guards inside where). `hk-parse-alt` now routes through + `hk-parse-rhs "->"`, `hk-parse-fun-clause` and `hk-parse-bind` through + `hk-parse-rhs "="`. `hk-parse-where-decls` reuses `hk-parse-decl` so + where-blocks accept any decl form (signatures, fixity, nested funs). + As a side effect, `hk-parse-bind` now also picks up the Haskell-native + `let f x = …` funclause shorthand: a varid followed by one or more + apats produces `(:fun-clause NAME APATS BODY)` instead of a + `(:bind (:p-var …) …)` — keeping the simple `let x = e` shape + unchanged for existing tests. 11 new tests in + `lib/haskell/tests/parser-guards-where.sx` cover two- and three-way + guards, mixed guarded + equality clauses, single- and multi-binding + where blocks, guards plus where, case-alt guards, case-alt where, + let with funclause shorthand, let with guards, and a where containing + a type signature alongside a fun-clause. 173/173 green. + - **2026-04-24** — Phase 1: top-level decls. Refactored `hk-parse-expr` into a `hk-parser tokens mode` with `:expr` / `:module` dispatch so the big lexical state is shared (peek/advance/pat/expr helpers all reachable); added public