diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | etc/system-tests.scm | 15 | ||||
| -rw-r--r-- | guix/monads.scm | 18 | ||||
| -rw-r--r-- | tests/monads.scm | 15 |
4 files changed, 32 insertions, 17 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 565f7c48e7..e4c1da8026 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -118,6 +118,7 @@ (eval . (put 'munless 'scheme-indent-function 1)) (eval . (put 'mlet* 'scheme-indent-function 2)) (eval . (put 'mlet 'scheme-indent-function 2)) + (eval . (put 'mparameterize 'scheme-indent-function 2)) (eval . (put 'run-with-store 'scheme-indent-function 1)) (eval . (put 'run-with-state 'scheme-indent-function 1)) (eval . (put 'wrap-program 'scheme-indent-function 1)) diff --git a/etc/system-tests.scm b/etc/system-tests.scm index de6f592dee..cd22b7e6d3 100644 --- a/etc/system-tests.scm +++ b/etc/system-tests.scm @@ -43,21 +43,6 @@ determined." (repository-close! repository)) #f)))) -(define-syntax mparameterize - (syntax-rules () - "This form implements dynamic scoping, similar to 'parameterize', but in a -monadic context." - ((_ monad ((parameter value) rest ...) body ...) - (let ((old-value (parameter))) - (mbegin monad - ;; XXX: Non-local exits are not correctly handled. - (return (parameter value)) - (mlet monad ((result (mparameterize monad (rest ...) body ...))) - (parameter old-value) - (return result))))) - ((_ monad () body ...) - (mbegin monad body ...)))) - (define (tests-for-current-guix source commit) "Return a list of tests for perform, using Guix built from SOURCE, a channel instance." diff --git a/guix/monads.scm b/guix/monads.scm index 6ae616aca9..0bd8ac9315 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +40,7 @@ mbegin mwhen munless + mparameterize lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift listm foldm @@ -398,6 +399,21 @@ expression." (mbegin %current-monad mexp0 mexp* ...))))) +(define-syntax mparameterize + (syntax-rules () + "This form implements dynamic scoping, similar to 'parameterize', but in a +monadic context." + ((_ monad ((parameter value) rest ...) body ...) + (let ((old-value (parameter))) + (mbegin monad + ;; XXX: Non-local exits are not correctly handled. + (return (parameter value)) + (mlet monad ((result (mparameterize monad (rest ...) body ...))) + (parameter old-value) + (return result))))) + ((_ monad () body ...) + (mbegin monad body ...)))) + (define-syntax define-lift (syntax-rules () ((_ liftn (args ...)) diff --git a/tests/monads.scm b/tests/monads.scm index 18bf4119be..19b74f4fb9 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -137,6 +137,19 @@ %monads %monad-run)) +(test-assert "mparameterize" + (let ((parameter (make-parameter 'outside))) + (every (lambda (monad run) + (equal? + (run (mlet monad ((outer (return (parameter))) + (inner + (mparameterize monad ((parameter 'inside)) + (return (parameter))))) + (return (list outer inner (parameter))))) + '(outside inside outside))) + %monads + %monad-run))) + (test-assert "mlet* + text-file + package-file" (run-with-store %store (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile")) |