diff options
| -rw-r--r-- | guix/monads.scm | 69 | ||||
| -rw-r--r-- | tests/monads.scm | 5 |
2 files changed, 59 insertions, 15 deletions
diff --git a/guix/monads.scm b/guix/monads.scm index 7862b0bce2..c705d014ec 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -17,14 +17,16 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix monads) - #:use-module (guix records) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module ((system syntax) + #:select (syntax-local-binding)) #:use-module (ice-9 match) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:export (;; Monads. - monad + define-monad monad? monad-bind monad-return @@ -72,11 +74,40 @@ ;;; ;;; Code: -(define-record-type* <monad> monad make-monad +;; Record type for monads manipulated at run time. +(define-record-type <monad> + (make-monad bind return) monad? (bind monad-bind) (return monad-return)) ; TODO: Add 'plus' and 'zero' +(define-syntax define-monad + (lambda (s) + "Define the monad under NAME, with the given bind and return methods." + (define prefix (string->symbol "% ")) + (define (make-rtd-name name) + (datum->syntax name + (symbol-append prefix (syntax->datum name) '-rtd))) + + (syntax-case s (bind return) + ((_ name (bind b) (return r)) + (with-syntax ((rtd (make-rtd-name #'name))) + #`(begin + (define rtd + ;; The record type, for use at run time. + (make-monad b r)) + + (define-syntax name + ;; An "inlined record", for use at expansion time. The goal is + ;; to allow 'bind' and 'return' to be resolved at expansion + ;; time, in the common case where the monad is accessed + ;; directly as NAME. + (lambda (s) + (syntax-case s (%bind %return) + ((_ %bind) #'b) + ((_ %return) #'r) + (_ #'rtd)))))))))) + (define-syntax-parameter >>= ;; The name 'bind' is already taken, so we choose this (obscure) symbol. (lambda (s) @@ -91,6 +122,15 @@ "Evaluate BODY in the context of MONAD, and return its result." (syntax-case s () ((_ monad body ...) + (eq? 'macro (syntax-local-binding #'monad)) + ;; MONAD is a syntax transformer, so we can obtain the bind and return + ;; methods by directly querying it. + #'(syntax-parameterize ((>>= (identifier-syntax (monad %bind))) + (return (identifier-syntax (monad %return)))) + body ...)) + ((_ monad body ...) + ;; MONAD refers to the <monad> record that represents the monad at run + ;; time, so use the slow method. #'(syntax-parameterize ((>>= (identifier-syntax (monad-bind monad))) (return (identifier-syntax @@ -209,16 +249,15 @@ lifted in MONAD, for which PROC returns true." ;;; Identity monad. ;;; -(define (identity-return value) +(define-inlinable (identity-return value) value) -(define (identity-bind mvalue mproc) +(define-inlinable (identity-bind mvalue mproc) (mproc mvalue)) -(define %identity-monad - (monad - (bind identity-bind) - (return identity-return))) +(define-monad %identity-monad + (bind identity-bind) + (return identity-return)) ;;; @@ -226,23 +265,23 @@ lifted in MONAD, for which PROC returns true." ;;; ;; return:: a -> StoreM a -(define (store-return value) +(define-inlinable (store-return value) "Return VALUE from a monadic function." ;; The monadic value is just this. (lambda (store) value)) ;; >>=:: StoreM a -> (a -> StoreM b) -> StoreM b -(define (store-bind mvalue mproc) +(define-inlinable (store-bind mvalue mproc) + "Bind MVALUE in MPROC." (lambda (store) (let* ((value (mvalue store)) (mresult (mproc value))) (mresult store)))) -(define %store-monad - (monad - (return store-return) - (bind store-bind))) +(define-monad %store-monad + (bind store-bind) + (return store-return)) (define (store-lift proc) diff --git a/tests/monads.scm b/tests/monads.scm index 9570c208b2..4608deec9e 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -48,6 +48,11 @@ (test-begin "monads") +(test-assert "monad?" + (and (every monad? %monads) + (every (compose procedure? monad-bind) %monads) + (every (compose procedure? monad-return) %monads))) + ;; The 3 "monad laws": <http://www.haskell.org/haskellwiki/Monad_laws>. (test-assert "left identity" |