haskell: full patterns — as/lazy/negative/infix + lambda & let pat LHS (+18 tests, 138/138)

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))

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

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

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))

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}