diff options
| -rw-r--r-- | .dir-locals.el | 3 | ||||
| -rw-r--r-- | ravanan/command-line-tool.scm | 2 | ||||
| -rw-r--r-- | ravanan/work/monads.scm | 63 |
3 files changed, 65 insertions, 3 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 311e2f7..49094d8 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -12,4 +12,5 @@ (eval . (put 'call-with-current-directory 'scheme-indent-function 1)) (eval . (put 'call-with-inferior 'scheme-indent-function 1)) (eval . (put 'maybe-let* 'scheme-indent-function 1)) - (eval . (put 'maybe-assoc-set 'scheme-indent-function 1)))) + (eval . (put 'maybe-assoc-set 'scheme-indent-function 1)) + (eval . (put 'state-let* 'scheme-indent-function 1)))) diff --git a/ravanan/command-line-tool.scm b/ravanan/command-line-tool.scm index ba9c181..7ce2ae8 100644 --- a/ravanan/command-line-tool.scm +++ b/ravanan/command-line-tool.scm @@ -34,7 +34,7 @@ #:use-module (guix gexp) #:use-module (guix inferior) #:use-module (guix modules) - #:use-module (guix monads) + #:use-module ((guix monads) #:select (mlet mbegin return)) #:use-module (guix profiles) #:use-module (guix search-paths) #:use-module (guix store) diff --git a/ravanan/work/monads.scm b/ravanan/work/monads.scm index 6d55449..4370ef3 100644 --- a/ravanan/work/monads.scm +++ b/ravanan/work/monads.scm @@ -33,7 +33,15 @@ maybe-vector-find maybe-assoc-ref maybe-assoc-set - maybe-alist)) + maybe-alist + + state-bind + state-return + state-let* + state-begin + current-state + set-current-state + run-with-state)) (define-immutable-record-type <monad> (monad bind return) @@ -180,3 +188,56 @@ maybe-monadic." (define maybe-alist (cut maybe-assoc-set (list) <...>)) + +(define-immutable-record-type <mstate> + (mstate state value) + mstate? + (state mstate-state) + (value mstate-value)) + +(define %state-monad + (monad (lambda (mvalue mproc) + (lambda (state) + (match (mvalue state) + (($ <mstate> next-state value) + ((mproc value) next-state))))) + (lambda (value) + (cut mstate <> value)))) + +(define state-bind + (monad-bind %state-monad)) + +;; We expose only a macro interface to the return function of the state monad +;; since we want its argument to be evaluated lazily. If we exposed a functional +;; interface, then a state-return used in isolation (that is, without a +;; state-bind) would have its argument evaluated eagerly and side-effects would +;; occur before the monad is actually run. FIXME: Unfortunately, this means that +;; we duplicate the definition of return in %state-monad. +(define-syntax-rule (state-return value) + ((lambda (delayed-value) + (cut mstate <> (force delayed-value))) + (delay value))) + +(define-syntax-rule (state-let* bindings body ...) + (mlet* %state-monad bindings + body ...)) + +(define-syntax-rule (state-begin body ...) + (mbegin %state-monad + body ...)) + +(define (current-state) + "Return the current state as a state-monadic value." + (lambda (state) + (mstate state state))) + +(define (set-current-state new-state) + "Set @var{new-state} as the state." + (cut mstate new-state <>)) + +(define* (run-with-state mvalue #:optional initial-state) + "Run state-monadic value @var{mvalue} starting with @var{initial-state}. Return +two values---the value encapsulated in @var{mvalue} and the final state." + (match (mvalue initial-state) + (($ <mstate> state value) + (values value state)))) |