;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 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 store)
- #:use-module (guix derivations)
- #:use-module (guix packages)
#:use-module ((system syntax)
#:select (syntax-local-binding))
#:use-module (ice-9 match)
monad-bind
monad-return
+ template-directory
+
;; Syntax.
>>=
return
;; Concrete monads.
%identity-monad
- %store-monad
- store-bind
- store-return
- store-lift
- run-with-store
- text-file
- interned-file
- package-file
- origin->derivation
- package->derivation
- package->cross-derivation
- built-derivations)
- #:replace (imported-modules
- compiled-modules))
+ %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:
;; Record type for monads manipulated at run time.
;; 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
((_ %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."
(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 ((>>= (identifier-syntax (monad %bind)))
+ #'(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 ((>>= (identifier-syntax
+ #'(syntax-parameterize ((>>= (bind-syntax
(monad-bind monad)))
(return (identifier-syntax
(monad-return monad))))
(define-syntax mbegin
(syntax-rules (%current-monad)
- "Bind the given monadic expressions in sequence, returning the result of
-the last one."
+ "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 ...)
(define-syntax mwhen
(syntax-rules ()
- "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'. When
-CONDITION is false, return *unspecified* in the current monad."
- ((_ condition exp0 exp* ...)
+ "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
- exp0 exp* ...)
+ mexp0 mexp* ...)
(return *unspecified*)))))
(define-syntax munless
(syntax-rules ()
- "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'. When
-CONDITION is true, return *unspecified* in the current monad."
- ((_ condition exp0 exp* ...)
+ "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
- exp0 exp* ...)))))
+ 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))
(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. LST items are bound from left to right, so effects in MONAD are known
-to happen in that order."
- (mlet monad ((result (foldm monad
- (lambda (item result)
- (mlet monad ((item (mproc item)))
- (return (cons item result))))
- '()
- lst)))
- (return (reverse result))))
-
-(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."
(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)
- (result -> (proc value)))
- (if result
- (return result)
- (loop tail))))))))
+ ((head . tail)
+ (>>= (mproc head)
+ (lambda (result)
+ (if result
+ (return result)
+ (loop tail)))))))))
(define-syntax listm
(lambda (s)
\f
;;;
-;;; Store monad.
-;;;
-
-;; return:: a -> StoreM a
-(define-inlinable (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-inlinable (store-bind mvalue mproc)
- "Bind MVALUE in MPROC."
- (lambda (store)
- (let* ((value (mvalue store))
- (mresult (mproc value)))
- (mresult store))))
-
-(define-monad %store-monad
- (bind store-bind)
- (return store-return))
-
-
-(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, a string."
- (lambda (store)
- (add-text-to-store store name text '())))
-
-(define* (interned-file file #:optional name
- #:key (recursive? #t))
- "Return the name of FILE once interned in the store. Use NAME as its store
-name, or the basename of FILE if NAME is omitted.
-
-When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
-designates a flat file and RECURSIVE? is true, its contents are added, and its
-permission bits are kept."
- (lambda (store)
- (add-to-store store (or name (basename file))
- recursive? "sha256" file)))
-
-(define* (package-file package
- #:optional file
- #:key
- system (output "out") target)
- "Return as a monadic value 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. When TARGET is true, use it as a
-cross-compilation target triplet."
- (lambda (store)
- (define compute-derivation
- (if target
- (cut package-cross-derivation <> <> target <>)
- package-derivation))
-
- (let* ((system (or system (%current-system)))
- (drv (compute-derivation store package system))
- (out (derivation->output-path drv output)))
- (if file
- (string-append out "/" file)
- out))))
-
-(define (lower-inputs inputs)
- "Turn any package from INPUTS into a derivation; return the corresponding
-input list as a monadic value."
- ;; XXX: This procedure is bound to disappear with 'derivation-expression'.
- (with-monad %store-monad
- (sequence %store-monad
- (map (match-lambda
- ((name (? package? package) sub-drv ...)
- (mlet %store-monad ((drv (package->derivation package)))
- (return `(,name ,drv ,@sub-drv))))
- ((name (? string? file))
- (return `(,name ,file)))
- (tuple
- (return tuple)))
- inputs))))
-
-(define derivation-expression
- ;; XXX: This procedure is superseded by 'gexp->derivation'.
- (store-lift build-expression->derivation))
-
-(define package->derivation
- (store-lift package-derivation))
-
-(define package->cross-derivation
- (store-lift package-cross-derivation))
-
-(define origin->derivation
- (store-lift package-source-derivation))
-
-(define imported-modules
- (store-lift (@ (guix derivations) imported-modules)))
-
-(define compiled-modules
- (store-lift (@ (guix derivations) compiled-modules)))
-
-(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."
- (define (default-guile)
- ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …)
- ;; modules directly, to avoid circular dependencies, hence this hack.
- (module-ref (resolve-interface '(gnu packages commencement))
- 'guile-final))
-
- (parameterize ((%guile-for-build (or guile-for-build
- (package-derivation store
- (default-guile)
- 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