diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | guix/monads.scm | 30 |
2 files changed, 31 insertions, 1 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 106c35bce6..b099068dac 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -46,6 +46,8 @@ (eval . (put 'syntax-parameterize 'scheme-indent-function 1)) (eval . (put 'with-monad 'scheme-indent-function 1)) (eval . (put 'mbegin 'scheme-indent-function 1)) + (eval . (put 'mwhen 'scheme-indent-function 1)) + (eval . (put 'munless 'scheme-indent-function 1)) (eval . (put 'mlet* 'scheme-indent-function 2)) (eval . (put 'mlet 'scheme-indent-function 2)) (eval . (put 'run-with-store 'scheme-indent-function 1)) diff --git a/guix/monads.scm b/guix/monads.scm index b419ba066a..52cb3f5ed0 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -39,6 +39,8 @@ mlet mlet* mbegin + mwhen + munless lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift listm foldm @@ -173,9 +175,15 @@ form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as body ...))))))) (define-syntax mbegin - (syntax-rules () + (syntax-rules (%current-monad) "Bind the given monadic expressions in sequence, returning the result of the last one." + ((_ %current-monad mexp) + mexp) + ((_ %current-monad mexp rest ...) + (>>= mexp + (lambda (unused-value) + (mbegin %current-monad rest ...)))) ((_ monad mexp) (with-monad monad mexp)) @@ -185,6 +193,26 @@ the last one." (lambda (unused-value) (mbegin monad rest ...))))))) +(define-syntax mwhen + (syntax-rules () + "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'. When +CONDITION is false, return *unspecified* in the current monad." + ((_ condition exp0 exp* ...) + (if condition + (mbegin %current-monad + exp0 exp* ...) + (return *unspecified*))))) + +(define-syntax munless + (syntax-rules () + "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'. When +CONDITION is true, return *unspecified* in the current monad." + ((_ condition exp0 exp* ...) + (if condition + (return *unspecified*) + (mbegin %current-monad + exp0 exp* ...))))) + (define-syntax define-lift (syntax-rules () ((_ liftn (args ...)) |