haskell: guards + where clauses (+11 tests, 173/173)

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
+      ;; ── RHS: guards + optional where ─────────────────────────
-      ;; (:bind (:p-var "x") e); pattern bindings like
+      ;; A rhs is either a plain body after `=`/`->`, or a list of
-      ;; `(x, y) = pair` parse with a p-tuple LHS.
+      ;; guarded bodies (`| cond = e | cond = e …`), optionally
+      ;; followed by a `where` block of local decls. Shapes:
+      ;;   plain:   <expr>
+      ;;   guards:  (:guarded ((:guard C1 E1) (:guard C2 E2) …))
+      ;;   where:   (:where <plain|guarded> 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)))
+            ((t (hk-peek)))
-            (hk-expect! "reservedop" "=")
+            (cond
-            (list :bind pat (hk-parse-expr-inner)))))
+              ((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-rhs "->")))))
-            (list :alt pat (hk-parse-expr-inner)))))
 
       (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-rhs "="))))
-                  (list :fun-clause name pats (hk-parse-expr-inner))))
               (:else
                 (let
                   ((pat (hk-parse-pat)))
-                  (hk-expect! "reservedop" "=")
+                  (list :pat-bind pat (hk-parse-rhs "="))))))))
-                  (list :pat-bind pat (hk-parse-expr-inner))))))))
 
       (define
         hk-parse-con-def

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}

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