X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=tests%2Ftest-agenda.scm;h=59c27b7ef21677431766f842b1940d43cb486373;hp=06f24f35c9a6329321eafdea161510bcf71d4aec;hb=cef48f426e254f8c05566a50669bf195560e0d96;hpb=743fdb8a79e771cfbd98ed53a66a4d129f8fe2f6 diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm index 06f24f3..59c27b7 100644 --- a/tests/test-agenda.scm +++ b/tests/test-agenda.scm @@ -1,29 +1,27 @@ -;; 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 -!# +;;; 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 (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 (eightsync agenda) + #:use-module (8sync agenda) #:use-module (tests utils)) (test-begin "test-agenda") @@ -40,8 +38,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)))) @@ -207,8 +222,8 @@ ;; ... whew! -;; Run/wrap request stuff -;; ---------------------- +;;; Run/wrap request stuff +;;; ====================== (let ((wrapped (wrap (+ 1 2)))) (test-assert (procedure? wrapped)) @@ -239,39 +254,48 @@ (test-equal (run-request-when run-two-squared) '(88 . 0))) -;;; %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) - 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) +;;; %run, 8sync and friends tests +;;; ============================== + +(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 -;;; ------------ +;;; ============ ;; helpers @@ -292,50 +316,27 @@ (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"))) -;; 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")))) - -(let ((q (make-q))) - (set! speaker (speak-it)) - (enq! q talk-about-the-zoo) - ;; (enq! q talk-about-the-zoo-but-wait) - (start-agenda (make-agenda #:queue q) - #: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"))) ;; End tests (test-end "test-agenda") +;; @@: A better way to handle this at the repl? (test-exit)