X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=tests%2Ftest-agenda.scm;h=59c27b7ef21677431766f842b1940d43cb486373;hp=d62e01ce284f777e831884cf9e9a0610413886f5;hb=cef48f426e254f8c05566a50669bf195560e0d96;hpb=34bbbef30ae633a221b0a190e06c3c82208e4a41 diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm index d62e01c..59c27b7 100644 --- a/tests/test-agenda.scm +++ b/tests/test-agenda.scm @@ -16,13 +16,10 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;;; 02110-1301 USA -#!/usr/bin/guile \ --s -!# - (define-module (tests test-agenda) #:use-module (srfi srfi-64) #:use-module (ice-9 q) + #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (8sync agenda) #:use-module (tests utils)) @@ -257,35 +254,44 @@ (test-equal (run-request-when run-two-squared) '(88 . 0))) -;;; %run, %8sync and friends tests +;;; %run, 8sync and friends tests ;;; ============================== -(define (test-%run-and-friends async-request expected-when) - (let* ((fake-kont (speak-it)) - (run-request ((@@ (8sync agenda) setup-async-request) - fake-kont async-request))) - (test-equal (car async-request) '*async-request*) - (test-equal (run-request-when run-request) expected-when) - ;; we're using speaker as a fake continuation ;p - ((run-request-proc run-request)) - (test-equal (fake-kont) - '("applesauce")))) - -(test-%run-and-friends (%run (string-concatenate '("apple" "sauce"))) - #f) - -(test-%run-and-friends (%run-at (string-concatenate '("apple" "sauce")) - '(8 . 0)) - '(8 . 0)) - -(test-%run-and-friends (%run-delay (string-concatenate '("apple" "sauce")) - 8) +(define-syntax-rule (run-in-fake-agenda + code-to-run) + (let ((agenda (make-agenda))) + (parameterize ((%current-agenda agenda)) + (call-with-prompt + (agenda-prompt-tag agenda) + (lambda () + (list '*normal-result* code-to-run)) + (lambda (kont async-request) + (list '*caught-kont* + kont async-request + ((@@ (8sync agenda) setup-async-request) + kont async-request))))))) + +(define (test-%run-and-friends run-result expected-when) + (match run-result + (('*caught-kont* kont async-request setup-request) + (let* ((fake-kont (speak-it)) + (run-request ((@@ (8sync agenda) setup-async-request) + fake-kont async-request))) + (test-equal (car async-request) '*async-request*) + (test-equal (run-request-when run-request) expected-when) + ;; we're using speaker as a fake continuation ;p + ((run-request-proc run-request)) + (test-equal (fake-kont) + '("applesauce")))))) + +(test-%run-and-friends (run-in-fake-agenda + (8sync-delay (string-concatenate '("apple" "sauce")) + 8)) ;; whoa, I'm surprised equal? can ;; compare records like this (tdelta 8)) -;; TODO: test %port-request -;; TODO: test %8sync and friends! +;; TODO: test 8sync and friends! ;;; Agenda tests @@ -326,111 +332,6 @@ (test-equal (speaker) '("I bet I can make you say you're a dummy!\n"))) -;; delimited continuation tests - -(define (return-monkey) - (speaker "(Hint, it's a monkey...)\n") - 'monkey) - -(define (talk-about-the-zoo) - (speaker "Today I went to the zoo and I saw...\n") - (speaker - (string-concatenate - `("A " ,(symbol->string (%8sync (%run (return-monkey)))) "!\n")))) - -(begin - (set! speaker (speak-it)) - ;; (enq! q talk-about-the-zoo-but-wait) - (start-agenda (make-agenda #:queue (make-q* talk-about-the-zoo)) - #:stop-condition (true-after-n-times 10)) - (test-equal (speaker) - '("Today I went to the zoo and I saw...\n" - "(Hint, it's a monkey...)\n" - "A monkey!\n"))) - - -;; Error handling tests -;; -------------------- - -(define (remote-func-breaks) - (speaker "Here we go...\n") - (+ 1 2 (/ 1 0)) - (speaker "SHOULD NOT HAPPEN\n")) - -(define (indirection-remote-func-breaks) - (speaker "bebop\n") - (%8sync (%run (remote-func-breaks))) - (speaker "bidop\n")) - -(define* (local-func-gets-break #:key with-indirection) - (speaker "Time for exception fun!\n") - (let ((caught-exception #f)) - (catch-8sync - (%8sync-run (if with-indirection - (indirection-remote-func-breaks) - (remote-func-breaks))) - ('numerical-overflow - (lambda (orig-stacks . orig-args) - (set! caught-exception #t) - (speaker "in here now!\n") - (test-equal orig-args '("/" "Numerical overflow" #f #f)) - (test-assert (list? orig-stacks)) - (test-equal (length orig-stacks) - (if with-indirection 2 1)) - (for-each - (lambda (x) - (test-assert (stack? x))) - orig-stacks)))) - (test-assert caught-exception)) - (speaker "Well that was fun :)\n")) - - -(begin - (set! speaker (speak-it)) - (start-agenda (make-agenda #:queue (make-q* local-func-gets-break)) - #:stop-condition (true-after-n-times 10)) - (test-equal (speaker) - '("Time for exception fun!\n" - "Here we go...\n" - "in here now!\n" - "Well that was fun :)\n"))) - -(begin - (set! speaker (speak-it)) - (start-agenda (make-agenda - #:queue (make-q* (wrap (local-func-gets-break - #:with-indirection #t)))) - #:stop-condition (true-after-n-times 10)) - (test-equal (speaker) - '("Time for exception fun!\n" - "bebop\n" - "Here we go...\n" - "in here now!\n" - "Well that was fun :)\n"))) - -;; Make sure catching tools work - -(let ((speaker (speak-it)) - (catch-result #f)) - (catch-8sync - (begin - (speaker "hello") - (throw '8sync-caught-error - 'my-orig-key '(apple orange banana) '(*fake-stack* *fake-stack* *fake-stack*)) - (speaker "no goodbyes")) - ('some-key - (lambda (stacks . rest) - (speaker "should not happen"))) - ('my-orig-key - (lambda (stacks fruit1 fruit2 fruit3) - (set! catch-result - `((fruit1 ,fruit1) - (fruit2 ,fruit2) - (fruit3 ,fruit3)))))) - (test-equal (speaker) '("hello")) - (test-equal catch-result '((fruit1 apple) - (fruit2 orange) - (fruit3 banana)))) ;; End tests