X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=tests%2Ftest-agenda.scm;h=d62e01ce284f777e831884cf9e9a0610413886f5;hp=e3e12c59a5491d2f09d4aae67a27fc265f66cd42;hb=34bbbef30ae633a221b0a190e06c3c82208e4a41;hpb=98edc693d1eb7ebe72c6ce722cf716c670cb21e3 diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm index e3e12c5..d62e01c 100644 --- a/tests/test-agenda.scm +++ b/tests/test-agenda.scm @@ -1,31 +1,33 @@ -;; Copyright (C) 2015 Christopher Allan Webber - -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 3 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -;; 02110-1301 USA +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2015 Christopher Allan Webber +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;;; 02110-1301 USA #!/usr/bin/guile \ -s !# -(define-module (tests test-core) +(define-module (tests test-agenda) #:use-module (srfi srfi-64) #:use-module (ice-9 q) #:use-module (ice-9 receive) - #:use-module (eightsync agenda)) + #:use-module (8sync agenda) + #:use-module (tests utils)) -(test-begin "tests-agenda") +(test-begin "test-agenda") @@ -39,8 +41,25 @@ messages))) -;; Timer tests -;; =========== +;;; queue helpers +;;; ============= + +(define test-q (list->q '(1 2 3))) +(test-equal (deq! test-q) 1) +(test-equal (deq! test-q) 2) +(test-equal (deq! test-q) 3) +(test-assert (q-empty? test-q)) + +(define test-q (make-q* 'apple 'banana 'carrot)) +(test-equal (deq! test-q) 'apple) +(test-equal (deq! test-q) 'banana) +(test-equal (deq! test-q) 'carrot) +(test-assert (q-empty? test-q)) + + + +;;; Timer tests +;;; =========== (test-assert (time= '(1 . 1) '(1 . 1))) (test-assert (not (time= '(1 . 1) '(1 . 0)))) @@ -206,8 +225,8 @@ ;; ... whew! -;; Run/wrap request stuff -;; ---------------------- +;;; Run/wrap request stuff +;;; ====================== (let ((wrapped (wrap (+ 1 2)))) (test-assert (procedure? wrapped)) @@ -238,12 +257,12 @@ (test-equal (run-request-when run-two-squared) '(88 . 0))) -;;; %run, %sync and friends tests -;;; ----------------------------- +;;; %run, %8sync and friends tests +;;; ============================== (define (test-%run-and-friends async-request expected-when) (let* ((fake-kont (speak-it)) - (run-request ((@@ (eightsync agenda) setup-async-request) + (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) @@ -263,14 +282,14 @@ 8) ;; whoa, I'm surprised equal? can ;; compare records like this - (tdelta 8 0)) + (tdelta 8)) ;; TODO: test %port-request -;; TODO: test %sync and friends! +;; TODO: test %8sync and friends! ;;; Agenda tests -;;; ------------ +;;; ============ ;; helpers @@ -291,20 +310,18 @@ (speaker "I bet I can make you say you're a dummy!\n") (run-it dummy-func)) -(let ((q (make-q))) +(begin (set! speaker (speak-it)) ; reset the speaker - (enq! q run-dummy) - (start-agenda (make-agenda #:queue q) + (start-agenda (make-agenda #:queue (make-q* run-dummy)) #:stop-condition (true-after-n-times 2)) (test-equal (speaker) '("I bet I can make you say you're a dummy!\n" "I'm a dummy\n"))) ;; should only do the first one after one round though -(let ((q (make-q))) +(begin (set! speaker (speak-it)) ; reset the speaker - (enq! q run-dummy) - (start-agenda (make-agenda #:queue q) + (start-agenda (make-agenda #:queue (make-q* run-dummy)) #:stop-condition (true-after-n-times 1)) (test-equal (speaker) '("I bet I can make you say you're a dummy!\n"))) @@ -319,21 +336,106 @@ (speaker "Today I went to the zoo and I saw...\n") (speaker (string-concatenate - `("A " ,(symbol->string (%sync (%run (return-monkey)))) "!\n")))) + `("A " ,(symbol->string (%8sync (%run (return-monkey)))) "!\n")))) -(let ((q (make-q))) +(begin (set! speaker (speak-it)) - (enq! q talk-about-the-zoo) ;; (enq! q talk-about-the-zoo-but-wait) - (start-agenda (make-agenda #:queue q) + (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 -(test-end "tests-agenda") -;; (test-exit) +(test-end "test-agenda") + +;; @@: A better way to handle this at the repl? +(test-exit)