129 lines
4.1 KiB
Scheme
129 lines
4.1 KiB
Scheme
;;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
|
||
;;;;
|
||
;;;; This program 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.
|
||
;;;;
|
||
;;;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (gnu gnunet monad)
|
||
#:use-module (guix monads)
|
||
#:use-module (gnu gnunet scheduler)
|
||
#:use-module (gnu gnunet identity)
|
||
#:use-module (gnu gnunet fs)
|
||
#:use-module (ice-9 match)
|
||
#:export (%task-monad
|
||
async
|
||
delayed
|
||
skip
|
||
run-with-scheduler
|
||
|
||
identity-service
|
||
file-sharing-service))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module provides the "task monad," a monad that abstracts over GNUnet
|
||
;;; tasks and callbacks. The goal is to "invert inversion of control" (IoC)
|
||
;;; so as to obtain more readable programs. This is essentially
|
||
;;; continuation-passing style (CPS) in disguise. Some monadic procedures
|
||
;;; such as 'identity-service' may return zero or several times because they
|
||
;;; correspond to callbacks.
|
||
;;;
|
||
;;; Code:
|
||
|
||
(define-inlinable (task-return value)
|
||
(lambda (cont)
|
||
(cont value)))
|
||
|
||
(define-inlinable (task-bind mvalue proc)
|
||
(lambda (cont)
|
||
(mvalue (lambda (value)
|
||
((proc value) cont)))))
|
||
|
||
(define-monad %task-monad
|
||
(bind task-bind)
|
||
(return task-return))
|
||
|
||
;; ((with-monad %task-monad
|
||
;; (>>= (return 42)
|
||
;; (lift1 1+ %task-monad)
|
||
;; (lift1 1+ %task-monad)
|
||
;; (lambda (x)
|
||
;; (return (* 2 x)))))
|
||
;; pk)
|
||
|
||
(define (run-with-scheduler config mvalue)
|
||
"Run MVALUE, a monadic value in %TASK-MONAD, using CONFIG. In practice this
|
||
starts the GNUnet scheduler and runs the given tasks."
|
||
(call-with-scheduler config
|
||
(lambda (x)
|
||
(mvalue identity))))
|
||
|
||
(define-inlinable (task thunk)
|
||
"Return the result of THUNK as a monadic value. THUNK will be invoked from
|
||
within a GNUnet task."
|
||
(lambda (cont)
|
||
(add-task! (lambda (_)
|
||
(cont (thunk))))))
|
||
|
||
(define-syntax-rule (async exp)
|
||
"Return the result of EXP as evaluated in an asynchronous task."
|
||
(task (lambda () exp)))
|
||
|
||
(define (delayed-task delay thunk)
|
||
(lambda (cont)
|
||
(add-task! (lambda (_)
|
||
(cont (thunk)))
|
||
#:delay delay)))
|
||
|
||
(define-syntax-rule (delayed usec exp)
|
||
"Return the result of EXP after waiting for USEC microseconds."
|
||
(delayed-task usec (lambda () exp)))
|
||
|
||
(define* (skip #:optional value)
|
||
"Skip the continuation and return VALUE."
|
||
(lambda (cont)
|
||
value))
|
||
|
||
|
||
;;;
|
||
;;; Monadic wrappers.
|
||
;;;
|
||
|
||
(define* (identity-service config)
|
||
"Return, zero or more times, an ego/name or ego/#f tuple corresponding to
|
||
CONFIG."
|
||
(lambda (cont)
|
||
(define service
|
||
(open-identity-service config
|
||
(lambda (ego name)
|
||
(if (not ego)
|
||
(add-task! (lambda (_)
|
||
(close-identity-service service)))
|
||
(cont (list ego name))))))
|
||
service))
|
||
|
||
(define* (file-sharing-service config name)
|
||
"Return, zero or more times, a handle/info/status tuple from the publication
|
||
service."
|
||
(lambda (cont)
|
||
(define service
|
||
(open-filesharing-service config name
|
||
(lambda (info status)
|
||
(match status
|
||
((#:publish #:stopped)
|
||
(close-filesharing-service! service))
|
||
(_
|
||
(cont (list service info status)))))))
|
||
service))
|
||
|
||
;;; monad.scm ends here
|