haskell: do-notation desugar + stub IO monad (return/>>=/>>) (+14 tests, 382/382)

lib/haskell/desugar.sx

@@ -29,6 +29,52 @@
             (hk-desugar (nth g 2))
             (hk-guards-to-if (rest guards))))))))
 
+;; do-notation desugaring (Haskell 98 §3.14):
+;;   do { e }              =  e
+;;   do { e ; ss }         =  e >> do { ss }
+;;   do { p <- e ; ss }    =  e >>= \p -> do { ss }
+;;   do { let decls ; ss } =  let decls in do { ss }
+(define
+  hk-desugar-do
+  (fn
+    (stmts)
+    (cond
+      ((empty? stmts) (raise "empty do block"))
+      ((empty? (rest stmts))
+        (let ((s (first stmts)))
+          (cond
+            ((= (first s) "do-expr") (hk-desugar (nth s 1)))
+            (:else
+              (raise "do block must end with an expression")))))
+      (:else
+        (let
+          ((s (first stmts)) (rest-stmts (rest stmts)))
+          (let
+            ((rest-do (hk-desugar-do rest-stmts)))
+            (cond
+              ((= (first s) "do-expr")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var ">>")
+                    (hk-desugar (nth s 1)))
+                  rest-do))
+              ((= (first s) "do-bind")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var ">>=")
+                    (hk-desugar (nth s 2)))
+                  (list :lambda (list (nth s 1)) rest-do)))
+              ((= (first s) "do-let")
+                (list
+                  :let
+                  (map hk-desugar (nth s 1))
+                  rest-do))
+              (:else (raise "unknown do-stmt tag")))))))))
+
 ;; List-comprehension desugaring (Haskell 98 §3.11):
 ;;   [e |             ]  =  [e]
 ;;   [e | b,     Q    ]  =  if b then [e | Q] else []
@@ -148,17 +194,7 @@
                 (map hk-desugar (nth node 2))))
             ((= tag "alt")
               (list :alt (nth node 1) (hk-desugar (nth node 2))))
-            ((= tag "do")
-              (list :do (map hk-desugar (nth node 1))))
-            ((= tag "do-expr")
-              (list :do-expr (hk-desugar (nth node 1))))
-            ((= tag "do-bind")
-              (list
-                :do-bind
-                (nth node 1)
-                (hk-desugar (nth node 2))))
-            ((= tag "do-let")
-              (list :do-let (map hk-desugar (nth node 1))))
+            ((= tag "do") (hk-desugar-do (nth node 1)))
             ((= tag "sect-left")
               (list
                 :sect-left

lib/haskell/eval.sx

@@ -614,6 +614,48 @@ plus a b = a + b
           "deepseq"
           (fn (a b) (do (hk-deep-force a) b))
           2))
+      ;; ── Stub IO monad ─────────────────────────────────────
+      ;; IO actions are tagged values `("IO" payload)`; `>>=` and
+      ;; `>>` chain them. Lazy in the action arguments so do-blocks
+      ;; can be deeply structured without forcing the whole chain
+      ;; up front.
+      (dict-set!
+        env
+        "return"
+        (hk-mk-lazy-builtin
+          "return"
+          (fn (x) (list "IO" x))
+          1))
+      (dict-set!
+        env
+        ">>="
+        (hk-mk-lazy-builtin
+          ">>="
+          (fn (m f)
+            (let ((io-val (hk-force m)))
+              (cond
+                ((and
+                    (list? io-val)
+                    (= (first io-val) "IO"))
+                  (hk-apply (hk-force f) (nth io-val 1)))
+                (:else
+                  (raise "(>>=): left side is not an IO action")))))
+          2))
+      (dict-set!
+        env
+        ">>"
+        (hk-mk-lazy-builtin
+          ">>"
+          (fn (m n)
+            (let ((io-val (hk-force m)))
+              (cond
+                ((and
+                    (list? io-val)
+                    (= (first io-val) "IO"))
+                  (hk-force n))
+                (:else
+                  (raise "(>>): left side is not an IO action")))))
+          2))
       ;; Operators as first-class values
       (dict-set! env "+" (hk-make-binop-builtin "+" "+"))
       (dict-set! env "-" (hk-make-binop-builtin "-" "-"))

lib/haskell/tests/do-io.sx

@@ -0,0 +1,117 @@
+;; do-notation + stub IO monad. Desugaring is per Haskell 98 §3.14:
+;;   do { e ; ss }      = e >> do { ss }
+;;   do { p <- e ; ss } = e >>= \p -> do { ss }
+;;   do { let ds ; ss } = let ds in do { ss }
+;;   do { e }           = e
+;; The IO type is just `("IO" payload)` for now — no real side
+;; effects yet. `return`, `>>=`, `>>` are built-ins.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+;; ── Single-statement do ──
+(hk-test
+  "do with a single expression"
+  (hk-eval-expr-source "do { return 5 }")
+  (list "IO" 5))
+
+(hk-test
+  "return wraps any expression"
+  (hk-eval-expr-source "return (1 + 2 * 3)")
+  (list "IO" 7))
+
+;; ── Bind threads results ──
+(hk-test
+  "single bind"
+  (hk-eval-expr-source
+    "do { x <- return 5 ; return (x + 1) }")
+  (list "IO" 6))
+
+(hk-test
+  "two binds"
+  (hk-eval-expr-source
+    "do\n  x <- return 5\n  y <- return 7\n  return (x + y)")
+  (list "IO" 12))
+
+(hk-test
+  "three binds — accumulating"
+  (hk-eval-expr-source
+    "do\n  a <- return 1\n  b <- return 2\n  c <- return 3\n  return (a + b + c)")
+  (list "IO" 6))
+
+;; ── Mixing >> and >>= ──
+(hk-test
+  ">> sequencing — last wins"
+  (hk-eval-expr-source
+    "do\n  return 1\n  return 2\n  return 3")
+  (list "IO" 3))
+
+(hk-test
+  ">> then >>= — last bind wins"
+  (hk-eval-expr-source
+    "do\n  return 99\n  x <- return 5\n  return x")
+  (list "IO" 5))
+
+;; ── do-let ──
+(hk-test
+  "do-let single binding"
+  (hk-eval-expr-source
+    "do\n  let x = 3\n  return (x * 2)")
+  (list "IO" 6))
+
+(hk-test
+  "do-let multi-bind, used after"
+  (hk-eval-expr-source
+    "do\n  let x = 4\n      y = 5\n  return (x * y)")
+  (list "IO" 20))
+
+(hk-test
+  "do-let interleaved with bind"
+  (hk-eval-expr-source
+    "do\n  x <- return 10\n  let y = x + 1\n  return (x * y)")
+  (list "IO" 110))
+
+;; ── Bind + pattern ──
+(hk-test
+  "bind to constructor pattern"
+  (hk-eval-expr-source
+    "do\n  Just x <- return (Just 7)\n  return (x + 100)")
+  (list "IO" 107))
+
+(hk-test
+  "bind to tuple pattern"
+  (hk-eval-expr-source
+    "do\n  (a, b) <- return (3, 4)\n  return (a * b)")
+  (list "IO" 12))
+
+;; ── User-defined IO functions ──
+(hk-test
+  "do inside top-level fun"
+  (hk-prog-val
+    "addM x y = do\n  a <- return x\n  b <- return y\n  return (a + b)\nresult = addM 5 6"
+    "result")
+  (list "IO" 11))
+
+(hk-test
+  "nested do"
+  (hk-eval-expr-source
+    "do\n  x <- do { y <- return 3 ; return (y + 1) }\n  return (x * 2)")
+  (list "IO" 8))
+
+;; ── (>>=) and (>>) used directly as functions ──
+(hk-test
+  ">>= used directly"
+  (hk-eval-expr-source
+    "(return 4) >>= (\\x -> return (x + 100))")
+  (list "IO" 104))
+
+(hk-test
+  ">> used directly"
+  (hk-eval-expr-source
+    "(return 1) >> (return 2)")
+  (list "IO" 2))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}