;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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 <http://www.gnu.org/licenses/>. (define-module (guix monads) #:use-module ((system syntax) #:select (syntax-local-binding)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:export (;; Monads. define-monad monad? monad-bind monad-return template-directory ;; Syntax. >>= return with-monad mlet mlet* mbegin mwhen munless lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift listm foldm mapm sequence anym ;; Concrete monads. %identity-monad %state-monad state-return state-bind current-state set-current-state state-push state-pop run-with-state)) ;;; Commentary: ;;; ;;; This module implements the general mechanism of monads, and provides in ;;; particular an instance of the "state" monad. The API was inspired by that ;;; of Racket's "better-monads" module (see ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>). ;;; The implementation and use case were influenced by Oleg Kysielov's ;;; "Monadic Programming in Scheme" (see ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>). ;;; ;;; Code: ;; 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)) ;; Instantiate all the templates, specialized for this monad. (template-directory instantiations name) (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)))))))))) ;; Expansion- and run-time state of the template directory. This needs to be ;; available at run time (and not just at expansion time) so we can ;; instantiate templates defined in other modules, or use instances defined ;; elsewhere. (eval-when (load expand eval) ;; Mapping of syntax objects denoting the template to a pair containing (1) ;; the syntax object of the parameter over which it is templated, and (2) ;; the syntax of its body. (define-once %templates (make-hash-table)) (define (register-template! name param body) (hash-set! %templates name (cons param body))) ;; List of template instances, where each entry is a triplet containing the ;; syntax of the name, the actual parameter for which the template is ;; specialized, and the syntax object referring to this specialization (the ;; procedure's identifier.) (define-once %template-instances '()) (define (register-template-instance! name actual instance) (set! %template-instances (cons (list name actual instance) %template-instances)))) (define-syntax template-directory (lambda (s) "This is a \"stateful macro\" to register and lookup templates and template instances." (define location (syntax-source s)) (define current-info-port ;; Port for debugging info. (const (%make-void-port "w"))) (define location-string (format #f "~a:~a:~a" (assq-ref location 'filename) (and=> (assq-ref location 'line) 1+) (assq-ref location 'column))) (define (matching-instance? name actual) (match-lambda ((name* instance-param proc) (and (free-identifier=? name name*) (or (equal? actual instance-param) (and (identifier? actual) (identifier? instance-param) (free-identifier=? instance-param actual))) proc)))) (define (instance-identifier name actual) (define stem (string-append " " (symbol->string (syntax->datum name)) (if (identifier? actual) (string-append " " (symbol->string (syntax->datum actual))) "") " instance")) (datum->syntax actual (string->symbol stem))) (define (instance-definition name template actual) (match template ((formal . body) (let ((instance (instance-identifier name actual))) (format (current-info-port) "~a: info: specializing '~a' for '~a' as '~a'~%" location-string (syntax->datum name) (syntax->datum actual) (syntax->datum instance)) (register-template-instance! name actual instance) #`(begin (define #,instance (let-syntax ((#,formal (identifier-syntax #,actual))) #,body)) ;; Generate code to register the thing at run time. (register-template-instance! #'#,name #'#,actual #'#,instance)))))) (syntax-case s (register! lookup exists? instantiations) ((_ register! name param body) ;; Register NAME as a template on PARAM with the given BODY. (begin (register-template! #'name #'param #'body) ;; Generate code to register the template at run time. XXX: Because ;; of this, BODY must not contain ellipses. #'(register-template! #'name #'param #'body))) ((_ lookup name actual) ;; Search for an instance of template NAME for this ACTUAL parameter. ;; On success, expand to the identifier of the instance; otherwise ;; expand to #f. (any (matching-instance? #'name #'actual) %template-instances)) ((_ exists? name actual) ;; Likewise, but return a Boolean. (let ((result (->bool (any (matching-instance? #'name #'actual) %template-instances)))) (unless result (format (current-warning-port) "~a: warning: no specialization of template '~a' for '~a'~%" location-string (syntax->datum #'name) (syntax->datum #'actual))) result)) ((_ instantiations actual) ;; Expand to the definitions of all the existing templates ;; specialized for ACTUAL. #`(begin #,@(hash-map->list (cut instance-definition <> <> #'actual) %templates)))))) (define-syntax define-template (lambda (s) "Define a template, which is a procedure that can be specialized over its first argument. In our case, the first argument is typically the identifier of a monad. Defining templates for procedures like 'mapm' allows us to make have a specialized version of those procedures for each monad that we define, such that calls to: (mapm %state-monad proc lst) automatically expand to: (#{ mapm %state-monad instance}# proc lst) Here, #{ mapm %state-monad instance}# is specialized for %state-monad, and thus it contains inline calls to %state-bind and %state-return. This avoids repeated calls to 'struct-ref' to get the 'bind' and 'return' procedure of the monad, and allows 'bind' and 'return' to be inlined, which in turn allows for more optimizations." (syntax-case s () ((_ (name arg0 args ...) body ...) (with-syntax ((generic-name (datum->syntax #'name (symbol-append '#{ %}# (syntax->datum #'name) '-generic))) (original-name #'name)) #`(begin (template-directory register! name arg0 (lambda (args ...) body ...)) (define (generic-name arg0 args ...) ;; The generic instance of NAME, for when no specialization was ;; found. body ...) (define-syntax name (lambda (s) (syntax-case s () ((_ arg0* args ...) ;; Expand to either the specialized instance or the ;; generic instance of template ORIGINAL-NAME. #'(if (template-directory exists? original-name arg0*) ((template-directory lookup original-name arg0*) args ...) (generic-name arg0* args ...))) (_ #'generic-name)))))))))) (define-syntax-rule (define-syntax-parameter-once name proc) ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME ;; does not get redefined. This works around a race condition in a ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. (eval-when (load eval expand compile) (define name (if (module-locally-bound? (current-module) 'name) (module-ref (current-module) 'name) (make-syntax-transformer 'name 'syntax-parameter (list proc)))))) (define-syntax-parameter-once >>= ;; 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-once return (lambda (s) (syntax-violation 'return "return used outside of 'with-monad'" s))) (define-syntax-rule (bind-syntax bind) "Return a macro transformer that handles the expansion of '>>=' expressions using BIND as the binary bind operator. This macro exists to allow the expansion of n-ary '>>=' expressions, even though BIND is simply binary, as in: (with-monad %state-monad (>>= (return 1) (lift 1+ %state-monad) (lift 1+ %state-monad))) " (lambda (stx) (define (expand body) (syntax-case body () ((_ mval mproc) #'(bind mval mproc)) ((x mval mproc0 mprocs (... ...)) (expand #'(>>= (>>= mval mproc0) mprocs (... ...)))))) (expand stx))) (define-syntax with-monad (lambda (s) "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 ((>>= (bind-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 ((>>= (bind-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 mbegin (syntax-rules (%current-monad) "Bind MEXP and the following monadic expressions in sequence, returning the result of the last expression. Every expression in the sequence must be a monadic expression." ((_ %current-monad mexp) mexp) ((_ %current-monad mexp rest ...) (>>= mexp (lambda (unused-value) (mbegin %current-monad rest ...)))) ((_ monad mexp) (with-monad monad mexp)) ((_ monad mexp rest ...) (with-monad monad (>>= mexp (lambda (unused-value) (mbegin monad rest ...))))))) (define-syntax mwhen (syntax-rules () "When CONDITION is true, evaluate the sequence of monadic expressions MEXP0..MEXP* as in an 'mbegin'. When CONDITION is false, return *unspecified* in the current monad. Every expression in the sequence must be a monadic expression." ((_ condition mexp0 mexp* ...) (if condition (mbegin %current-monad mexp0 mexp* ...) (return *unspecified*))))) (define-syntax munless (syntax-rules () "When CONDITION is false, evaluate the sequence of monadic expressions MEXP0..MEXP* as in an 'mbegin'. When CONDITION is true, return *unspecified* in the current monad. Every expression in the sequence must be a monadic expression." ((_ condition mexp0 mexp* ...) (if condition (return *unspecified*) (mbegin %current-monad mexp0 mexp* ...))))) (define-syntax define-lift (syntax-rules () ((_ liftn (args ...)) (define-syntax liftn (lambda (s) "Lift PROC to MONAD---i.e., return a monadic function in MONAD." (syntax-case s () ((liftn proc monad) ;; Inline the result of lifting PROC, such that 'return' can in ;; turn be open-coded. #'(lambda (args ...) (with-monad monad (return (proc args ...))))) (id (identifier? #'id) ;; Slow path: Return a closure-returning procedure (we don't ;; guarantee (eq? LIFTN LIFTN), but that's fine.) #'(lambda (proc monad) (lambda (args ...) (with-monad monad (return (proc args ...)))))))))))) (define-lift lift0 ()) (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 proc monad) "Lift PROC, a procedure that accepts an arbitrary number of arguments, to MONAD---i.e., return a monadic function in MONAD." (lambda args (with-monad monad (return (apply proc args))))) (define-template (foldm monad mproc init lst) "Fold MPROC over LST and return a monadic value seeded by INIT. (foldm %state-monad (lift2 cons %state-monad) '() '(a b c)) => '(c b a) ;monadic " (with-monad monad (let loop ((lst lst) (result init)) (match lst (() (return result)) ((head . tail) (>>= (mproc head result) (lambda (result) (loop tail result)))))))) (define-template (mapm monad mproc lst) "Map MPROC over LST and return a monadic list. (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2)) => (1 2 3) ;monadic " ;; XXX: We don't use 'foldm' because template specialization wouldn't work ;; in this context. (with-monad monad (let mapm ((lst lst) (result '())) (match lst (() (return (reverse result))) ((head . tail) (>>= (mproc head) (lambda (head) (mapm tail (cons head result))))))))) (define-template (sequence monad lst) "Turn the list of monadic values LST into a monadic list of values, by evaluating each item of LST in sequence." (with-monad monad (let seq ((lstx lst) (result '())) (match lstx (() (return (reverse result))) ((head . tail) (>>= head (lambda (item) (seq tail (cons item result))))))))) (define-template (anym monad mproc lst) "Apply MPROC to the list of values LST; return as a monadic value the first value for which MPROC returns a true monadic value or #f. For example: (anym %state-monad (lift1 odd? %state-monad) '(0 1 2)) => #t ;monadic " (with-monad monad (let loop ((lst lst)) (match lst (() (return #f)) ((head . tail) (>>= (mproc head) (lambda (result) (if result (return result) (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-inlinable (identity-return value) value) (define-inlinable (identity-bind mvalue mproc) (mproc mvalue)) (define-monad %identity-monad (bind identity-bind) (return identity-return)) ;;; ;;; State monad. ;;; (define-inlinable (state-return value) (lambda (state) (values value state))) (define-inlinable (state-bind mvalue mproc) "Bind MVALUE, a value in the state monad, and pass it to MPROC." (lambda (state) (call-with-values (lambda () (mvalue state)) (lambda (value state) ;; Note: as of Guile 2.0.11, declaring a variable to hold the result ;; of (mproc value) prevents a bit of unfolding/inlining. ((mproc value) state))))) (define-monad %state-monad (bind state-bind) (return state-return)) (define* (run-with-state mval #:optional (state '())) "Run monadic value MVAL starting with STATE as the initial state. Return two values: the resulting value, and the resulting state." (mval state)) (define-inlinable (current-state) "Return the current state as a monadic value." (lambda (state) (values state state))) (define-inlinable (set-current-state value) "Set the current state to VALUE and return the previous state as a monadic value." (lambda (state) (values state value))) (define (state-pop) "Pop a value from the current state and return it as a monadic value. The state is assumed to be a list." (lambda (state) (match state ((head . tail) (values head tail))))) (define (state-push value) "Push VALUE to the current state, which is assumed to be a list, and return the previous state as a monadic value." (lambda (state) (values state (cons value state)))) ;;; monads.scm end here