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

haskell: do-notation desugar + stub IO monad (return/>>=/>>) (+14 tests, 382/382)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
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