mirror of
git://git.savannah.gnu.org/guix.git
synced 2023-12-14 03:33:07 +01:00
8245bb74fc
Fixes <https://bugs.gnu.org/27476>. This fixes multi-threaded compilation of this code where syntax parameters could end up being redefined and where a race condition could lead a thread to see the "wrong" value of the syntax parameter. * guix/monads.scm (define-syntax-parameter-once): New macro. (>>=, return): Use it. * guix/gexp.scm (define-syntax-parameter-once): New macro. (current-imported-modules, current-imported-extensions): Use it.
598 lines
20 KiB
Scheme
598 lines
20 KiB
Scheme
;;; 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
|