tests/utils.scm

   1 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   2 ;;;
   3 ;;; This library is free software; you can redistribute it and/or
   4 ;;; modify it under the terms of the GNU Lesser General Public
   5 ;;; License as published by the Free Software Foundation; either
   6 ;;; version 3 of the License, or (at your option) any later version.
   7 ;;;
   8 ;;; This library is distributed in the hope that it will be useful,
   9 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;; Lesser General Public License for more details.
  12 ;;;
  13 ;;; You should have received a copy of the GNU Lesser General Public
  14 ;;; License along with this program.  If not, see
  15 ;;; <http://www.gnu.org/licenses/>.
  16
  17 ;; Thanks for giving permission to license this under LGPL for
  18 ;; consistency, David!
  19
  20
  21 (define-module (tests utils)
  22   #:use-module (srfi srfi-64)
  23   #:export (test-exit
  24
  25             speak get-spoken with-fresh-speaker))
  26
  27 (define (test-exit)
  28   (exit (= (test-runner-fail-count (test-runner-current)) 0)))
  29
  30
  31 \f
  32
  33 ;;; display-like helpers
  34 ;;; ====================
  35
  36 (define (speak-it)
  37   (let ((messages '()))
  38     (lambda* (#:optional message)
  39       (if message (set! messages (append messages (list message))))
  40       messages)))
  41
  42 (define %speaker (make-parameter (speak-it)))
  43
  44 (define (speak message)
  45   "Speak a message into the %speaker parameter"
  46   ((%speaker) message))
  47
  48 (define (get-spoken)
  49   "Get what's been spoken in the %speaker parameter"
  50   ((%speaker)))
  51
  52 (define-syntax-rule (with-fresh-speaker body ...)
  53   "Run body with a fresh %speaker"
  54   (parameterize ((%speaker (speak-it)))
  55     body ...))