From b860f382447a360ea2ce8a89d3357279cc652c3a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 3 Oct 2013 22:45:25 +0200 Subject: Add (guix monads). * guix/monads.scm: New file. * tests/monads.scm: New file. * Makefile.am (MODULES): Add guix/monads.scm. (SCM_TESTS): Add tests/monads.scm. * doc/guix.texi (The Store Monad): New node. (The Store): Reference it. --- guix/monads.scm | 306 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 306 insertions(+) create mode 100644 guix/monads.scm (limited to 'guix/monads.scm') diff --git a/guix/monads.scm b/guix/monads.scm new file mode 100644 index 0000000000..7862b0bce2 --- /dev/null +++ b/guix/monads.scm @@ -0,0 +1,306 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix monads) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (;; Monads. + monad + monad? + monad-bind + monad-return + + ;; Syntax. + >>= + return + with-monad + mlet + mlet* + lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift + listm + foldm + mapm + sequence + anym + + ;; Concrete monads. + %identity-monad + + %store-monad + store-bind + store-return + store-lift + run-with-store + text-file + package-file + package->derivation + built-derivations + derivation-expression)) + +;;; Commentary: +;;; +;;; This module implements the general mechanism of monads, and provides in +;;; particular an instance of the "store" monad. The API was inspired by that +;;; of Racket's "better-monads" module (see +;;; ). +;;; The implementation and use case were influenced by Oleg Kysielov's +;;; "Monadic Programming in Scheme" (see +;;; ). +;;; +;;; The store monad allows us to (1) build sequences of operations in the +;;; store, and (2) make the store an implicit part of the execution context, +;;; rather than a parameter of every single function. +;;; +;;; Code: + +(define-record-type* monad make-monad + monad? + (bind monad-bind) + (return monad-return)) ; TODO: Add 'plus' and 'zero' + +(define-syntax-parameter >>= + ;; The name 'bind' is already taken, so we choose this (obscure) symbol. + (lambda (s) + (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) + +(define-syntax-parameter return + (lambda (s) + (syntax-violation 'return "return used outside of 'with-monad'" s))) + +(define-syntax with-monad + (lambda (s) + "Evaluate BODY in the context of MONAD, and return its result." + (syntax-case s () + ((_ monad body ...) + #'(syntax-parameterize ((>>= (identifier-syntax + (monad-bind monad))) + (return (identifier-syntax + (monad-return monad)))) + body ...))))) + +(define-syntax mlet* + (syntax-rules (->) + "Bind the given monadic values MVAL to the given variables VAR. When the +form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as +'let'." + ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'. + ((_ monad () body ...) + (with-monad monad body ...)) + ((_ monad ((var mval) rest ...) body ...) + (with-monad monad + (>>= mval + (lambda (var) + (mlet* monad (rest ...) + body ...))))) + ((_ monad ((var -> val) rest ...) body ...) + (let ((var val)) + (mlet* monad (rest ...) + body ...))))) + +(define-syntax mlet + (lambda (s) + (syntax-case s () + ((_ monad ((var mval ...) ...) body ...) + (with-syntax (((temp ...) (generate-temporaries #'(var ...)))) + #'(mlet* monad ((temp mval ...) ...) + (let ((var temp) ...) + body ...))))))) + +(define-syntax define-lift + (syntax-rules () + ((_ liftn (args ...)) + (define (liftn proc monad) + "Lift PROC to MONAD---i.e., return a monadic function in MONAD." + (lambda (args ...) + (with-monad monad + (return (proc args ...)))))))) + +(define-lift lift1 (a)) +(define-lift lift2 (a b)) +(define-lift lift3 (a b c)) +(define-lift lift4 (a b c d)) +(define-lift lift5 (a b c d e)) +(define-lift lift6 (a b c d e f)) +(define-lift lift7 (a b c d e f g)) + +(define (lift nargs proc monad) + "Lift PROC, a procedure that accepts NARGS arguments, to MONAD---i.e., +return a monadic function in MONAD." + (lambda args + (with-monad monad + (return (apply proc args))))) + +(define (foldm monad mproc init lst) + "Fold MPROC over LST, a list of monadic values in MONAD, and return a +monadic value seeded by INIT." + (with-monad monad + (let loop ((lst lst) + (result init)) + (match lst + (() + (return result)) + ((head tail ...) + (mlet* monad ((item head) + (result (mproc item result))) + (loop tail result))))))) + +(define (mapm monad mproc lst) + "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic +list." + (foldm monad + (lambda (item result) + (mlet monad ((item (mproc item))) + (return (cons item result)))) + '() + (reverse lst))) + +(define-inlinable (sequence monad lst) + "Turn the list of monadic values LST into a monadic list of values, by +evaluating each item of LST in sequence." + ;; FIXME: 'mapm' binds from right to left. + (with-monad monad + (mapm monad return lst))) + +(define (anym monad proc lst) + "Apply PROC to the list of monadic values LST; return the first value, +lifted in MONAD, for which PROC returns true." + (with-monad monad + (let loop ((lst lst)) + (match lst + (() + (return #f)) + ((head tail ...) + (mlet monad ((value head)) + (or (and=> (proc value) return) + head + (loop tail)))))))) + +(define-syntax listm + (lambda (s) + "Return a monadic list in MONAD from the monadic values MVAL." + (syntax-case s () + ((_ monad mval ...) + (with-syntax (((val ...) (generate-temporaries #'(mval ...)))) + #'(mlet monad ((val mval) ...) + (return (list val ...)))))))) + + + +;;; +;;; Identity monad. +;;; + +(define (identity-return value) + value) + +(define (identity-bind mvalue mproc) + (mproc mvalue)) + +(define %identity-monad + (monad + (bind identity-bind) + (return identity-return))) + + +;;; +;;; Store monad. +;;; + +;; return:: a -> StoreM a +(define (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) + (lambda (store) + (let* ((value (mvalue store)) + (mresult (mproc value))) + (mresult store)))) + +(define %store-monad + (monad + (return store-return) + (bind store-bind))) + + +(define (store-lift proc) + "Lift PROC, a procedure whose first argument is a connection to the store, +in the store monad." + (define result + (lambda args + (lambda (store) + (apply proc store args)))) + + (set-object-property! result 'documentation + (procedure-property proc 'documentation)) + result) + +;;; +;;; Store monad operators. +;;; + +(define* (text-file name text) + "Return as a monadic value the absolute file name in the store of the file +containing TEXT." + (lambda (store) + (add-text-to-store store name text '()))) + +(define* (package-file package + #:optional file + #:key (system (%current-system)) (output "out")) + "Return as a monadic value in the absolute file name of FILE within the +OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the +OUTPUT directory of PACKAGE." + (lambda (store) + (let* ((drv (package-derivation store package system)) + (out (derivation->output-path drv output))) + (if file + (string-append out "/" file) + out)))) + +(define derivation-expression + (store-lift build-expression->derivation)) + +(define package->derivation + (store-lift package-derivation)) + +(define built-derivations + (store-lift build-derivations)) + +(define* (run-with-store store mval + #:key + (guile-for-build (%guile-for-build)) + (system (%current-system))) + "Run MVAL, a monadic value in the store monad, in STORE, an open store +connection." + (parameterize ((%guile-for-build (or guile-for-build + (package-derivation store + (@ (gnu packages base) + guile-final) + system))) + (%current-system system)) + (mval store))) + +;;; monads.scm end here -- cgit v1.2.3