X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=tests%2Ftest-agenda.scm;h=ae53e55cf6db9440950d860a3f1d1afaaf9419b6;hp=bbf22d28fbaaa98a1184092a9fe0fffeabef9612;hb=f0863bf36133288ed55eb97a3732d581be45c231;hpb=2a468eba78a9fee4cff48550bb675130daea1e1f diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm index bbf22d2..ae53e55 100644 --- a/tests/test-agenda.scm +++ b/tests/test-agenda.scm @@ -1,46 +1,60 @@ -;; 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) +;;; 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 "tests-agenda") +(test-begin "test-agenda") + +(define-syntax-rule (%import var) + (define var + (@@ (8sync agenda) var))) +;;; 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)) -;;; Helpers -;;; ======= +(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)) -(define (speak-it) - (let ((messages '())) - (lambda* (#:optional message) - (if message (set! messages (append messages (list message)))) - messages))) -;; Timer tests -;; =========== +;;; Timer tests +;;; =========== + +(%import time=) +(%import time<) +(%import time-minus) +(%import time-plus) (test-assert (time= '(1 . 1) '(1 . 1))) (test-assert (not (time= '(1 . 1) '(1 . 0)))) @@ -52,27 +66,24 @@ (test-assert (not (time< '(7 . 8) '(7 . 2)))) (test-assert (not (time< '(8 . 2) '(7 . 2)))) -(let ((tdelta (make-time-delta 8))) - (test-assert (time-delta? tdelta)) - (test-eqv (time-delta-sec tdelta) 8) - (test-eqv (time-delta-usec tdelta) 0) - (test-equal - (time-delta+ '(2 . 3) tdelta) - '(10 . 3))) +(test-equal (time-minus '(100 . 100) '(50 . 66)) + '(50 . 34)) +(test-equal (time-minus '(2 . 0) '(0 . 1)) + '(1 . 999999)) -(let ((tdelta (make-time-delta '(10 . 1)))) - (test-assert (time-delta? tdelta)) - (test-eqv (time-delta-sec tdelta) 10) - (test-eqv (time-delta-usec tdelta) 1) - (test-equal - (time-delta+ '(2 . 3) tdelta) - '(12 . 4))) +(test-equal (time-plus '(50 . 34) '(50 . 66)) + '(100 . 100)) +(test-equal (time-plus '(1 . 999999) '(1 . 2)) + '(3 . 1)) ;;; Schedule tests ;;; ============== +(%import time-segment-time) +(%import time-segment-queue) + ;; helpers (define (assert-times-expected time-segments expected-times) (test-equal (map time-segment-time time-segments) @@ -89,7 +100,7 @@ (test-assert (schedule-empty? sched)) ;; Add a segment at (10 . 0) -(schedule-add! sched 10 a-proc) +(schedule-add! sched '(10 . 0) a-proc) (test-assert (not (schedule-empty? sched))) (test-equal (length (schedule-segments sched)) 1) (test-equal (time-segment-time (car (schedule-segments sched))) @@ -121,7 +132,7 @@ '((10 . 0))) ;; Add a segment to (11 . 0), (8 . 1) and (10 . 10) -(schedule-add! sched 11 c-proc) +(schedule-add! sched '(11 . 0) c-proc) (schedule-add! sched '(8 . 1) d-proc) (schedule-add! sched '(10 . 10) e-proc) (test-assert (not (schedule-empty? sched))) @@ -136,7 +147,7 @@ (assert-times-expected segments-before expected-before) (assert-times-expected segments-after expected-after))) -(test-split-at sched 0 +(test-split-at sched '(0 . 0) '() '((8 . 1) (10 . 0) (10 . 10) (11 . 0))) (test-split-at sched '(8 . 0) @@ -145,13 +156,13 @@ (test-split-at sched '(8 . 1) '((8 . 1)) '((10 . 0) (10 . 10) (11 . 0))) -(test-split-at sched 9 +(test-split-at sched '(9 . 0) '((8 . 1)) '((10 . 0) (10 . 10) (11 . 0))) -(test-split-at sched 10 +(test-split-at sched '(10 . 0) '((8 . 1) (10 . 0)) '((10 . 10) (11 . 0))) -(test-split-at sched 9000 +(test-split-at sched '(9000 . 0) '((8 . 1) (10 . 0) (10 . 10) (11 . 0)) '()) (test-split-at sched '(9000 . 1) ; over nine thousaaaaaaand @@ -160,7 +171,7 @@ ;; Break off half of those and do some tests on them (define some-extracted - (schedule-extract-until! sched 10)) + (schedule-extract-until! sched '(10 . 0))) (assert-times-expected some-extracted '((8 . 1) (10 . 0))) (assert-times-expected (schedule-segments sched) '((10 . 10) (11 . 0))) (define first-extracted-queue @@ -196,8 +207,8 @@ ;; ... whew! -;; Run/wrap request stuff -;; ---------------------- +;;; Run/wrap request stuff +;;; ====================== (let ((wrapped (wrap (+ 1 2)))) (test-assert (procedure? wrapped)) @@ -228,102 +239,52 @@ (test-equal (run-request-when run-two-squared) '(88 . 0))) -;;; %run, %sync 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) - ;; whoa, I'm surprised equal? can - ;; compare records like this - (tdelta 8 0)) - -;; TODO: test %port-request -;; TODO: test %sync and friends! +;;; %run, 8sync and friends tests +;;; ============================== +;; TODO: We need to rewrite the whole lot here... ;;; Agenda tests -;;; ------------ +;;; ============ ;; helpers (define (true-after-n-times n) (let ((count 0)) (lambda _ + (define ans + (if (>= count n) #t #f)) (set! count (+ count 1)) - (if (>= count n) #t #f)))) + ans))) ;; the dummy test -(define speaker (speak-it)) - (define (dummy-func) - (speaker "I'm a dummy\n")) + (speak "I'm a dummy\n")) (define (run-dummy) - (speaker "I bet I can make you say you're a dummy!\n") + (speak "I bet I can make you say you're a dummy!\n") (run-it dummy-func)) -(let ((q (make-q))) - (set! speaker (speak-it)) ; reset the speaker - (enq! q run-dummy) - (start-agenda (make-agenda #:queue q) - #: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"))) +(with-fresh-speaker + (start-agenda (make-agenda #:queue (make-q* run-dummy)) + #:stop-condition (true-after-n-times 2)) + (test-equal (get-spoken) + '("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))) - (set! speaker (speak-it)) ; reset the speaker - (enq! q run-dummy) - (start-agenda (make-agenda #:queue q) - #: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 (%sync (%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"))) +(with-fresh-speaker + (start-agenda (make-agenda #:queue (make-q* run-dummy)) + #:stop-condition (true-after-n-times 1)) + (test-equal (get-spoken) + '("I bet I can make you say you're a dummy!\n"))) + ;; End tests -(test-end "tests-agenda") -;; (test-exit) +(test-end "test-agenda") + +;; @@: A better way to handle this at the repl? +(test-exit)