From cd489b19be17d2c7a4b0f74000a379668b6c58dd Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 00:59:42 +0000 Subject: [PATCH] haskell: do-notation desugar + stub IO monad (return/>>=/>>) (+14 tests, 382/382) --- lib/haskell/desugar.sx | 58 ++++++++++++++---- lib/haskell/eval.sx | 42 +++++++++++++ lib/haskell/tests/do-io.sx | 117 +++++++++++++++++++++++++++++++++++++ plans/haskell-on-sx.md | 22 ++++++- 4 files changed, 227 insertions(+), 12 deletions(-) create mode 100644 lib/haskell/tests/do-io.sx diff --git a/lib/haskell/desugar.sx b/lib/haskell/desugar.sx index c44fbe89..b61a9453 100644 --- a/lib/haskell/desugar.sx +++ b/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 diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 13272701..a626180b 100644 --- a/lib/haskell/eval.sx +++ b/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 "-" "-")) diff --git a/lib/haskell/tests/do-io.sx b/lib/haskell/tests/do-io.sx new file mode 100644 index 00000000..d4425376 --- /dev/null +++ b/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} diff --git a/plans/haskell-on-sx.md b/plans/haskell-on-sx.md index 3c46b2c2..443f8696 100644 --- a/plans/haskell-on-sx.md +++ b/plans/haskell-on-sx.md @@ -80,7 +80,7 @@ Key mappings: - [x] Pattern match forces scrutinee before matching - [x] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream (sieve deferred — needs lazy `++` and is exercised under `Classic programs`) - [x] `seq`, `deepseq` from Prelude -- [ ] Do-notation for a stub `IO` monad (just threading, no real side effects yet) +- [x] Do-notation for a stub `IO` monad (just threading, no real side effects yet) - [ ] Classic programs in `lib/haskell/tests/programs/`: - [ ] `fib.hs` — infinite Fibonacci stream - [ ] `sieve.hs` — lazy sieve of Eratosthenes @@ -114,6 +114,26 @@ Key mappings: _Newest first._ +- **2026-04-25** — Phase 3 do-notation + stub IO monad. Added a + `hk-desugar-do` pass that follows Haskell 98 §3.14 verbatim: + `do { e } = e`, `do { e ; ss } = e >> do { ss }`, + `do { p <- e ; ss } = e >>= \p -> do { ss }`, and + `do { let ds ; ss } = let ds in do { ss }`. The desugarer's + `:do` branch now invokes this pass directly so the surface + AST forms (`:do-expr`, `:do-bind`, `:do-let`) never reach the + evaluator. IO is represented as a tagged value + `("IO" payload)` — `return` (lazy builtin) wraps; `>>=` (lazy + builtin) forces the action, unwraps, and calls the bound + function on the payload; `>>` (lazy builtin) forces the + action and returns the second one. All three are non-strict + in their action arguments so deeply nested do-blocks don't + walk the whole chain at construction time. 14 new tests in + `lib/haskell/tests/do-io.sx` cover single-stmt do, single + and multi-bind, `>>` sequencing (last action wins), do-let + (single, multi, interleaved with bind), bind-to-`Just`, + bind-to-tuple, do inside a top-level fun, nested do, and + using `(>>=)`/`(>>)` directly as functions. 382/382 green. + - **2026-04-25** — Phase 3 `seq` + `deepseq`. Built-ins were strict in all args by default (every collected thunk forced before invoking the underlying SX fn) — that defeats `seq`'s purpose,