;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; 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-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (;; Monads.
- monad
+ define-monad
monad?
monad-bind
monad-return
+ template-directory
+
;; Syntax.
>>=
return
with-monad
mlet
mlet*
- lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
+ mbegin
+ mwhen
+ munless
+ lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
listm
foldm
mapm
;; 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))
+ %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 "store" monad. The API was inspired by that
+;;; 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>).
;;;
-;;; 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> 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))
+
+ ;; 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)
(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 ...)
- #'(syntax-parameterize ((>>= (identifier-syntax
+ (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))))
(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 (liftn proc monad)
- "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
- (lambda (args ...)
- (with-monad monad
- (return (proc 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 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."
+(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 (foldm monad mproc init lst)
- "Fold MPROC over LST, a list of monadic values in MONAD, and return a
-monadic value seeded by INIT."
+(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 ...)
- (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)
+ ((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."
- ;; 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."
+ (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 ...)
- (mlet monad ((value head))
- (or (and=> (proc value) return)
- head
- (loop tail))))))))
+ ((head . tail)
+ (>>= (mproc head)
+ (lambda (result)
+ (if result
+ (return result)
+ (loop tail)))))))))
(define-syntax listm
(lambda (s)
;;; 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))
\f
;;;
-;;; 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.
+;;; State monad.
;;;
-(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)))
+(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
HCoop / jackhill / guix / guix.git / blobdiff