me
/
guix
Archived
1
0
Fork 0
This repository has been archived on 2024-08-07. You can view files and clone it, but cannot push or open issues/pull-requests.
guix/guix/monads.scm

588 lines
20 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

;;; 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-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-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