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
-      ;; (: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:   <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)))
-            (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