From 92eeab2815eae6cd9ef22530d2e50fe0a620ec46 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sun, 9 Jun 2024 05:13:44 +0900 Subject: Initial commit --- algebraic-structs.monad.make.scm | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 algebraic-structs.monad.make.scm (limited to 'algebraic-structs.monad.make.scm') diff --git a/algebraic-structs.monad.make.scm b/algebraic-structs.monad.make.scm new file mode 100644 index 0000000..0598309 --- /dev/null +++ b/algebraic-structs.monad.make.scm @@ -0,0 +1,29 @@ +(functor ((algebraic-structs monad make) (M (pure map map2 >>=))) + (pure map map2 >>= do) + (import (rename scheme (map scheme:map) (do scheme:do)) + M) + (import-for-syntax matchable + (chicken syntax) + (only (srfi 1) last)) + + (define-syntax do + (ir-macro-transformer + (lambda (expr inject compare) + (match expr + [(_ body ...) + (foldr (lambda (binding acc) + (match binding + [(var stx expr) + (if (and (symbol? stx) (compare stx (inject '<-))) + `(>>= ,expr (lambda (,var) ,acc)) + `(>>= ,binding (lambda (_) ,acc)))] + [(let-stx var =-stx expr) + (cond ((and (symbol? let-stx) (compare let-stx (inject 'let)) + (symbol? =-stx) (compare =-stx (inject '=))) + `((lambda (,var) ,acc) ,expr)) + (else + `(>>= ,binding (lambda (_) ,acc))))] + [expr + `(>>= ,expr (lambda (_) ,acc))])) + (last body) + (butlast body))]))))) -- cgit v1.2.3