From c33495ab47b0e35e8ab7ee5de810ebc538604f0e Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Fri, 13 Sep 2024 02:49:36 +0100 Subject: monads: Rename module to (ravanan work monads). * ravanan/monads.scm: Move to ravanan/work/monads.scm. * ravanan/command-line-tool.scm, ravanan/propnet.scm, ravanan/reader.scm, ravanan/workflow.scm: Import (ravanan work vectors) instead of (ravanan vectors). --- ravanan/command-line-tool.scm | 2 +- ravanan/monads.scm | 173 ------------------------------------------ ravanan/propnet.scm | 2 +- ravanan/reader.scm | 2 +- ravanan/work/monads.scm | 173 ++++++++++++++++++++++++++++++++++++++++++ ravanan/workflow.scm | 2 +- 6 files changed, 177 insertions(+), 177 deletions(-) delete mode 100644 ravanan/monads.scm create mode 100644 ravanan/work/monads.scm diff --git a/ravanan/command-line-tool.scm b/ravanan/command-line-tool.scm index 5676ce0..df7e8fa 100644 --- a/ravanan/command-line-tool.scm +++ b/ravanan/command-line-tool.scm @@ -48,12 +48,12 @@ #:use-module (ravanan config) #:use-module (ravanan glob) #:use-module (ravanan job-state) - #:use-module (ravanan monads) #:use-module (ravanan propnet) #:use-module (ravanan reader) #:use-module (ravanan slurm-api) #:use-module (ravanan vectors) #:use-module (ravanan work command-line-tool) + #:use-module (ravanan work monads) #:use-module (ravanan work types) #:use-module (ravanan work ui) #:use-module (ravanan work utils) diff --git a/ravanan/monads.scm b/ravanan/monads.scm deleted file mode 100644 index dfbeacd..0000000 --- a/ravanan/monads.scm +++ /dev/null @@ -1,173 +0,0 @@ -;;; ravanan --- High-reproducibility CWL runner powered by Guix -;;; Copyright © 2024 Arun Isaac -;;; -;;; This file is part of ravanan. -;;; -;;; ravanan 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. -;;; -;;; ravanan 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 ravanan. If not, see . - -(define-module (ravanan monads) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-43) - #:use-module (ice-9 match) - #:export (maybe-monad - maybe-bind - just - %nothing - nothing? - maybe-let* - from-maybe - maybe->list - maybe-find - maybe-vector-find - maybe-assoc-ref - maybe-assoc-set - maybe-alist)) - -(define-immutable-record-type - (monad bind return) - monad? - (bind monad-bind) - (return monad-return)) - -(define-syntax mlet* - (syntax-rules () - ((_ monad-type () body ...) - (begin - body ...)) - ((_ monad-type ((var mvalue) bindings ...) body ...) - ((monad-bind monad-type) - mvalue - (lambda (var) - (mlet* monad-type (bindings ...) - body ...)))))) - -(define-immutable-record-type - (maybe value valid?) - maybe? - (value maybe-value) - (valid? maybe-valid?)) - -(set-record-type-printer! - (lambda (record port) - (if (maybe-valid? record) - (begin - (display "[Just " port) - (display (maybe-value record) port) - (display "]" port)) - (display "Nothing" port)))) - -(define %maybe-monad - (monad (lambda (m proc) - (if (maybe-valid? m) - (proc (maybe-value m)) - %nothing)) - (cut maybe <> #t))) - -(define maybe-bind - (monad-bind %maybe-monad)) - -(define just - (monad-return %maybe-monad)) - -(define %nothing - (maybe #f #f)) - -(define nothing? - (negate maybe-valid?)) - -(define-syntax-rule (maybe-let* bindings body ...) - (mlet* %maybe-monad bindings - body ...)) - -;; We define from-maybe as a macro since default should not be eagerly -;; evaluated. -(define-syntax-rule (from-maybe mvalue default) - "If maybe-monadic @var{mvalue} is @code{%nothing}, return -@var{default}. Else, return the value contained within." - (if (maybe-valid? mvalue) - (maybe-value mvalue) - default)) - -(define (maybe->list mvalue) - "If maybe-monadic @var{mvalue} is @code{%nothing}, return an empty -list. Else, return a singleton list of the value contained within." - (if (maybe-valid? mvalue) - (list (maybe-value mvalue)) - (list))) - -(define (maybe-find pred lst) - "Find the first element of @var{lst} that satisfies @var{pred}, and -return it as a maybe value. Return @code{%nothing} if no such element -is found." - (match (find-tail pred lst) - ((element . _) (just element)) - (#f %nothing))) - -(define (maybe-vector-find pred vec) - "Find the first element of @var{vec} that satisfies @var{pred}, and -return it as a maybe value. Return @code{%nothing} if no such element -is found." - (or (vector-any (lambda (x) - (and (pred x) - (just x))) - vec) - %nothing)) - -(define (maybe-assoc-ref maybe-alist . keys) - "Return the value addressed by @var{keys} in maybe-monadic -@var{maybe-alist}. The return value is also maybe-monadic." - (fold (lambda (key result) - (maybe-bind result - (lambda (alist) - (match (assoc key alist) - ((_ . value) (just value)) - (_ %nothing))))) - maybe-alist - keys)) - -(define (assoc-set alist . pairs) - "Return a new association alist with keys in @var{alist} set to values -as specified in @var{pairs}. Each element of @var{pairs} maps an -atomic key to a value. Keys may also be a list of atomic values -specifying a path through the association list tree." - (fold (lambda (pair result) - (match pair - (((key) . value) - (assoc-set alist (cons key value))) - (((head-key tail-key-path ...) . value) - (acons head-key - (assoc-set (assoc-ref result head-key) - (cons tail-key-path value)) - (alist-delete head-key result))) - ((key . value) - (acons key value - (alist-delete key result))))) - alist - pairs)) - -(define (maybe-assoc-set alist . key-maybe-value-pairs) - "Like @code{assoc-set}, but values in @var{key-maybe-value-pairs} are -maybe-monadic." - (apply assoc-set - alist - (filter-map (match-lambda - ((key . value) - (and (maybe-valid? value) - (cons key (maybe-value value))))) - key-maybe-value-pairs))) - -(define maybe-alist - (cut maybe-assoc-set (list) <...>)) diff --git a/ravanan/propnet.scm b/ravanan/propnet.scm index c820864..52a00bc 100644 --- a/ravanan/propnet.scm +++ b/ravanan/propnet.scm @@ -23,7 +23,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-71) #:use-module (ice-9 match) - #:use-module (ravanan monads) + #:use-module (ravanan work monads) #:use-module (ravanan work utils) #:export (propnet propnet-propagators diff --git a/ravanan/reader.scm b/ravanan/reader.scm index 6f1fdfe..a4c2002 100644 --- a/ravanan/reader.scm +++ b/ravanan/reader.scm @@ -23,9 +23,9 @@ #:use-module (ice-9 match) #:use-module (json) #:use-module (yaml) - #:use-module (ravanan monads) #:use-module (ravanan vectors) #:use-module (ravanan work command-line-tool) + #:use-module (ravanan work monads) #:use-module (ravanan work utils) #:export (read-workflow read-inputs)) diff --git a/ravanan/work/monads.scm b/ravanan/work/monads.scm new file mode 100644 index 0000000..7a2cb11 --- /dev/null +++ b/ravanan/work/monads.scm @@ -0,0 +1,173 @@ +;;; ravanan --- High-reproducibility CWL runner powered by Guix +;;; Copyright © 2024 Arun Isaac +;;; +;;; This file is part of ravanan. +;;; +;;; ravanan 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. +;;; +;;; ravanan 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 ravanan. If not, see . + +(define-module (ravanan work monads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-43) + #:use-module (ice-9 match) + #:export (maybe-monad + maybe-bind + just + %nothing + nothing? + maybe-let* + from-maybe + maybe->list + maybe-find + maybe-vector-find + maybe-assoc-ref + maybe-assoc-set + maybe-alist)) + +(define-immutable-record-type + (monad bind return) + monad? + (bind monad-bind) + (return monad-return)) + +(define-syntax mlet* + (syntax-rules () + ((_ monad-type () body ...) + (begin + body ...)) + ((_ monad-type ((var mvalue) bindings ...) body ...) + ((monad-bind monad-type) + mvalue + (lambda (var) + (mlet* monad-type (bindings ...) + body ...)))))) + +(define-immutable-record-type + (maybe value valid?) + maybe? + (value maybe-value) + (valid? maybe-valid?)) + +(set-record-type-printer! + (lambda (record port) + (if (maybe-valid? record) + (begin + (display "[Just " port) + (display (maybe-value record) port) + (display "]" port)) + (display "Nothing" port)))) + +(define %maybe-monad + (monad (lambda (m proc) + (if (maybe-valid? m) + (proc (maybe-value m)) + %nothing)) + (cut maybe <> #t))) + +(define maybe-bind + (monad-bind %maybe-monad)) + +(define just + (monad-return %maybe-monad)) + +(define %nothing + (maybe #f #f)) + +(define nothing? + (negate maybe-valid?)) + +(define-syntax-rule (maybe-let* bindings body ...) + (mlet* %maybe-monad bindings + body ...)) + +;; We define from-maybe as a macro since default should not be eagerly +;; evaluated. +(define-syntax-rule (from-maybe mvalue default) + "If maybe-monadic @var{mvalue} is @code{%nothing}, return +@var{default}. Else, return the value contained within." + (if (maybe-valid? mvalue) + (maybe-value mvalue) + default)) + +(define (maybe->list mvalue) + "If maybe-monadic @var{mvalue} is @code{%nothing}, return an empty +list. Else, return a singleton list of the value contained within." + (if (maybe-valid? mvalue) + (list (maybe-value mvalue)) + (list))) + +(define (maybe-find pred lst) + "Find the first element of @var{lst} that satisfies @var{pred}, and +return it as a maybe value. Return @code{%nothing} if no such element +is found." + (match (find-tail pred lst) + ((element . _) (just element)) + (#f %nothing))) + +(define (maybe-vector-find pred vec) + "Find the first element of @var{vec} that satisfies @var{pred}, and +return it as a maybe value. Return @code{%nothing} if no such element +is found." + (or (vector-any (lambda (x) + (and (pred x) + (just x))) + vec) + %nothing)) + +(define (maybe-assoc-ref maybe-alist . keys) + "Return the value addressed by @var{keys} in maybe-monadic +@var{maybe-alist}. The return value is also maybe-monadic." + (fold (lambda (key result) + (maybe-bind result + (lambda (alist) + (match (assoc key alist) + ((_ . value) (just value)) + (_ %nothing))))) + maybe-alist + keys)) + +(define (assoc-set alist . pairs) + "Return a new association alist with keys in @var{alist} set to values +as specified in @var{pairs}. Each element of @var{pairs} maps an +atomic key to a value. Keys may also be a list of atomic values +specifying a path through the association list tree." + (fold (lambda (pair result) + (match pair + (((key) . value) + (assoc-set alist (cons key value))) + (((head-key tail-key-path ...) . value) + (acons head-key + (assoc-set (assoc-ref result head-key) + (cons tail-key-path value)) + (alist-delete head-key result))) + ((key . value) + (acons key value + (alist-delete key result))))) + alist + pairs)) + +(define (maybe-assoc-set alist . key-maybe-value-pairs) + "Like @code{assoc-set}, but values in @var{key-maybe-value-pairs} are +maybe-monadic." + (apply assoc-set + alist + (filter-map (match-lambda + ((key . value) + (and (maybe-valid? value) + (cons key (maybe-value value))))) + key-maybe-value-pairs))) + +(define maybe-alist + (cut maybe-assoc-set (list) <...>)) diff --git a/ravanan/workflow.scm b/ravanan/workflow.scm index 9e9e868..0f4bcdb 100644 --- a/ravanan/workflow.scm +++ b/ravanan/workflow.scm @@ -22,11 +22,11 @@ #:use-module (ice-9 filesystem) #:use-module (ice-9 match) #:use-module (ravanan command-line-tool) - #:use-module (ravanan monads) #:use-module (ravanan propnet) #:use-module (ravanan reader) #:use-module (ravanan vectors) #:use-module (ravanan work command-line-tool) + #:use-module (ravanan work monads) #:use-module (ravanan work ui) #:use-module (ravanan work utils) #:export (run-workflow)) -- cgit v1.2.3