Add task conditions
This commit is contained in:
parent
09e4f6d806
commit
b19eaf1007
2 changed files with 53 additions and 10 deletions
38
modules/ordo/condition.scm
Normal file
38
modules/ordo/condition.scm
Normal file
|
@ -0,0 +1,38 @@
|
||||||
|
(define-module (ordo condition)
|
||||||
|
#:use-moudle (ordo context)
|
||||||
|
#:use-module (ordo action filesystem))
|
||||||
|
|
||||||
|
(define (cond:any preds)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let loop ((preds preds))
|
||||||
|
(if (null? preds)
|
||||||
|
#f
|
||||||
|
(let ((p (car preds)))
|
||||||
|
(if (p ctx)
|
||||||
|
#t
|
||||||
|
(loop (cdr preds))))))))
|
||||||
|
|
||||||
|
(define (cond:every preds)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let loop ((preds preds))
|
||||||
|
(if (null? preds)
|
||||||
|
#t
|
||||||
|
(let ((p (car preds)))
|
||||||
|
(if (p ctx)
|
||||||
|
(loop (cdr preds))
|
||||||
|
#f))))))
|
||||||
|
|
||||||
|
(define (cond:command-available? cmd-name)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let ((_ rc) (run "which" `(,cmd-name)))
|
||||||
|
(zero? rc))))
|
||||||
|
|
||||||
|
(define (cond:directory? path)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let ((st ((action:stat path) ctx)))
|
||||||
|
(and st (string=? "directory" (assoc-ref st 'file-type))))))
|
||||||
|
|
||||||
|
(define (cond:regular-file? path)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let ((st ((action:stat path) ctx)))
|
||||||
|
(and st (string=? "regular-file" (assoc-ref st 'file-type))))))
|
|
@ -7,28 +7,33 @@
|
||||||
#:export (task
|
#:export (task
|
||||||
task?
|
task?
|
||||||
task-description
|
task-description
|
||||||
|
task-condition
|
||||||
task-action
|
task-action
|
||||||
task-register
|
task-register
|
||||||
task-triggers
|
task-triggers
|
||||||
run-task))
|
run-task))
|
||||||
|
|
||||||
(define-record-type <task>
|
(define-record-type <task>
|
||||||
(make-task description action register triggers)
|
(make-task description condition action register triggers)
|
||||||
task?
|
task?
|
||||||
(description task-description)
|
(description task-description)
|
||||||
|
(condition task-condition)
|
||||||
(action task-action)
|
(action task-action)
|
||||||
(register task-register)
|
(register task-register)
|
||||||
(triggers task-triggers))
|
(triggers task-triggers))
|
||||||
|
|
||||||
(define* (task description action #:key (register #f) (triggers '()))
|
(define* (task description action #:key (condition (const #t)) (register #f) (triggers '()))
|
||||||
(make-task description action register triggers))
|
(make-task description condition action register triggers))
|
||||||
|
|
||||||
(define (run-task ctx t)
|
(define (run-task ctx t)
|
||||||
(match t
|
(match t
|
||||||
(($ <task> description action register triggers)
|
(($ <task> description condition action register triggers)
|
||||||
(format #t "RUNNING TASK ~a~%" description)
|
(if (not (condition ctx))
|
||||||
(let ((result (action ctx)))
|
(format #t "SKIPPING TASK ~a (precondition not met)~%" description)
|
||||||
(when register
|
(begin
|
||||||
(register-context-var! ctx register result))
|
(format #t "RUNNING TASK ~a~%" description)
|
||||||
(when triggers
|
(let ((result (action ctx)))
|
||||||
(add-context-triggers! ctx triggers))))))
|
(when register
|
||||||
|
(register-context-var! ctx register result))
|
||||||
|
(when triggers
|
||||||
|
(add-context-triggers! ctx triggers))))))))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue