coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

haskell: do-notation desugar + stub IO monad (return/>>=/>>) (+14 tests, 382/382)
Some checks are pending
Test, Build, and Deploy / test-build-deploy (push) Waiting to run
Details

Browse Source
This commit is contained in:
giles
2026-04-25 00:59:42 +00:00
parent 04a25d17d0
commit cd489b19be
4 changed files with 227 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
lib/haskell/desugar.sx
View File

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

42
lib/haskell/eval.sx
View File

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

117
lib/haskell/tests/do-io.sx Normal file
View File

@@ -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}

22
plans/haskell-on-sx.md
View File

@@ -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,