ulambda/bootstrap/rebirth/test.scm

;;;; Viability suite for Rebirth Lisp
;;;;
;;;;  Copyright (C) 2018 Mike Gerwitz
;;;;
;;;;  This file is part of Ulambda Scheme.
;;;;
;;;;  Ulambda Scheme is free software: you can redistribute it and/or modify
;;;;  it under the terms of the GNU Affero General Public License as
;;;;  published by the Free Software Foundation, either version 3 of the
;;;;  License, or (at your option) any later version.
;;;;
;;;;  This program 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 General Public License for more details.
;;;;
;;;;  You should have received a copy of the GNU Affero General Public License
;;;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;



;;; Commentary:

;;; THIS IS BOOTSTRAP CODE INTENDED FOR USE ONLY IN REBIRTH.
;;;
;;;
;;; Rebirth has two major goals:
;;;   1. Be just good enough to begin writing Ulambda in a sane Lisp dialect
;;;      without having to make too many negative compromises; and
;;;   2. To prove that certain implementation details are
;;;      successful---Rebirth is an experiment in a number of concepts.
;;;
;;; Rebirth is to be considered _viable_ when it meets both of those
;;; goals.  The viability of Rebirth is determined by this test suite.
;;;
;;; This file should be compiled using the last generation of Rebirth and
;;; directly executed.  There are no external dependencies or fancy
;;; libraries here, since Rebirth is too primitive to support much of
;;; that.  If successful, this compiled script should exit with a zero
;;; status code.
;;;
;;; Certain tests may be marked as skipped if Rebirth features are under
;;; development.
;;;

;;; Code:



;; TODO: These ought to be automatically included by Rebirth
(include "rebirth/es.scm")
(include "rebirth/relibprebirth.scm")
(include "rebirth/macro.scm")
(define (not x)
  (if x #f #t))



;;; {Test Runner}
;;;

;; This runner uses an imperative style because Rebirth lacks convenient
;; functional primitives (and so this is far more concise).  Mutators are
;; discouraged in Ulambda.
;;
;; These counts are increased during test execution.
(define testn 0)
(define testfail 0)
(define skipn 0)


;; Output message to standard out.
(define (output str)
  (es:console str))


;; Run suite of tests described by TESTS.
;;
;; Test results are output as an S-expression.
(define-macro (test-suite . tests)
  (`quote
   (begin
     (output "(test-results")
     (unquote@ tests)
     (test-report))))


;; Group tests TESTS into a topic with description DESC
;;
;; The description DESC will be output as a comment along with the number of
;; tests in TESTS.  This is intended purely as a visual aid.
(define-macro (topic desc . tests)
  (`quote
   (begin
     (output (string-append "  ;; " (unquote desc)
                            " (" (unquote (length tests)) ")"))
     (unquote@ tests))))


;; Verify that the given value VALUE matches the expected value EXPECTED.
;;
;; A line describing this test will be output as an S-expression (see
;; `test-result').
(define-macro (verify desc value expected)
  (`quote
   (let* ((result (es:try (unquote value)
                          (lambda (err) err)))
          (ok     (deep-eq? result (unquote expected))))
     (test-result (unquote desc)
                  ok
                  (if ok "ok" "FAIL")
                  result)
     (if (not ok) (set! testfail (+ 1 testfail))))))


;; Skip a test and output it as such.
;;
;; This should only ever be used when test cases are written to demonstrate
;; failing cases with the intent to fix them.  It is dangerous to use this
;; template, since they could easily be forgotten about---skipped tests do
;; _not_ fail.
(define-macro (skip desc . _)
  (`quote
   (begin
     (test-result (unquote desc) #t "SKIP" #f)
     (set! skipn (+ 1 skipn)))))


;; Output result of a test.
;;
;; An S-expression will be output including the test number; result of the
;; test as a string TAG; a description DESC of the test; and, on failure, a
;; comment describing the bad value as a JSON-encoded string (because that's
;; convenient; Rebirth does not have a pretty-printer for S-expressions).
(define (test-result desc ok tag result)
  (output (string-append "  (" testn " '" tag " \"" desc "\")"
                         (if (not ok)
                             (string-append " ; " (es:json-stringify result)))))
  (set! testn (+ 1 testn)))


;; Output a final test report with total, failure, and skip counts.
;;
;; This outputs a line as an S-expression and adds the closing parenthesis
;; for `test-suite'.
;;
;; If there are any failures, an error is thrown.
(define (test-report)
  (output (string-append "  (summary (tests . " testn ") "
                         "(failures . " testfail ") "
                         "(skipped . " skipn "))"))
  (if (not (eq? testfail 0))
      (error "Rebirth is not viable!")))


;; Primitive recursive eq? check.
(define (deep-eq? x y)
  ;; Universal quantifier over list LS for truthy values.
  (define (everyt? ls)
    (fold (lambda (x y) (and x y))
          #t
          ls))

  (or (and (list? x)
           (list? y)
           (eq? (length x) (length y))
           (everyt? (map deep-eq? x y)))

      (and (not (or (list? x)
                    (list? y)))
           (eq? x y))))




;;; {Test Cases}
;;;

(test-suite
 (topic "car"
   (verify "car of pair"
     (car (list 1))
     1)
   (verify "car of multi-element pair"
     (car (list 2 3))
     2))

 (topic "cdr"
   (verify "cdr of pair"
     (cdr (list 1))
     (list))
   (verify "cdr of multi-eement pair"
     (cdr (list 1 2))
     (list 2))
   (skip "cdr of improper cons'd pair"
     (cdr (cons 1 2))
     2)
   (skip "cdr of proper dotted pair"
     (cdr (quote (1 . (2 3))))
     (list 2 3))
   (skip "cdr of improper dotted pair"
     (cdr (quote (1 . 2)))
     2))

 (topic "lists"
   (verify "list? with empty list"
     (list? (list))
     #t)
   (verify "list? with non-empty list"
     (list? (list 1 2))
     #t)
   (skip "list? with two-element improper list"
     (list? (quote (1 . 2)))
     #f)
   (skip "list? with many-element improper list"
     (list? (quote (1 2 3 . 4)))
     #f)
   (verify "list? with non-list object"
     (or (list? 5)
         (list? #t)
         (list? #f)
         (list? (quote symbol))
         (list? "string"))
     #f)
   (verify "list? with proper cons"
     (list? (cons 1 (list)))
     #t)
   (skip "list? with improper cons"
     (list? (cons 1 2))
     #f)
   (verify "pair? with empty list"
     (pair? (list))
     #f)
   (verify "pair? with single-element list"
     (pair? (list 1))
     #t)
   (verify "pair? with multi-element list"
     (pair? (list 1 2))
     #t)
   (skip "pair? with improper list"
     (pair? (quote (1 . 2)))
     #t)
   (verify "pair? with proper cons"
     (pair? (cons 1 (list)))
     #t)
   (skip "pair? with improper cons"
     (pair? (cons 1 2))
     #t)
   (verify "length of list"
     (length (list 1 2 3 4 5))
     5))

 (topic "lambda/define"
   (verify "thunk"
     (begin
       (define f (lambda () (quote thunky)))
       (f))
     (quote thunky))
   (verify "with parameters"
     (begin
       (define f (lambda (x y) (list x y)))
       (f (quote a) (quote b)))
     (list (quote a) (quote b)))
   (verify "define procedure shorthand"
     (begin
       (define (f x y) (list x y))
       (f (quote a) (quote b)))
     (list (quote a) (quote b)))
   (verify "define varadic"
     (begin
       (define (f x y . rest)
         (list x y rest))
       (f 1 2 3 4 5))
     (list 1 2 (list 3 4 5)))
   (verify "define value"
     (begin
       (define x 5)
       x)
     5))

 (topic "let/let*"
   (verify "let with no bindings"
     (let () (quote ok))
     (quote ok))
   (verify "let with one binding"
     (let ((x 1)) x)
     1)
   (verify "let with multiple bindings"
     (let ((x 1)
           (y 2))
       (list x y))
     (list 1 2))
   (verify "let reference sibling binding"
     (let ((x 1))
       (let ((x 2)
             (y x))
         y))
     1)
   (verify "let with multiple body expressions"
     (let ()
       1
       2
       3)
     3)

   (verify "let* with no bindings"
     (let* () (quote ok))
     (quote ok))
   (verify "let* with one binding"
     (let* ((x 1)) x)
     1)
   (verify "let* with multiple bindings"
     (let* ((x 1)
            (y 2))
       (list x y))
     (list 1 2))
   (verify "let* reference sibling binding"
     (let* ((x 1))
       (let* ((x 2)
              (y x))
         y))
     2)
   (verify "let* with multiple body expressions"
     (let ()
       2
       3
       4)
     4))

 (topic "begin"
   (verify "begin with one expression"
     (begin (quote ok))
     (quote ok))
   (verify "begin with multiple expressions"
     (begin
       (quote first)
       (quote second)
       (quote third))
     (quote third))
   (verify "begin with definition"
     (begin
       (define x 5)
       x)
     5))

 (topic "strings"
   (verify "substring with start and end"
     (substring "foobar" 2 5)
     "oba")
   (verify "string-length"
     (string-length "foo")
     3)
   (verify "string=? with differing strings"
     (string=? "foo" "bar")
     #f)
   (verify "string=? with identical strings"
     (string=? "baz" "baz")
     #t)
   (verify "string-append with no strings"
     (string-append)
     "")
   (verify "string-append with one string"
     (string-append "foo")
     "foo")
   (verify "string-append with many strings"
     (string-append "foo" "bar" "baz" "quux")
     "foobarbazquux"))

 (topic "math"
   (verify "+ with no argments"
     (+)
     0)
   (verify "+ with one argument"
     (+ 5)
     5)
   (verify "+ with two arguments"
     (+ 5 4)
     9)
   (verify "+ with multiple arguments"
     (+ 5 4 3 -2 -1)
     9)
   (verify "- with one argument"
     (- 3)
     -3)
   (verify "- with two arguments"
     (- 3 2)
     1)
   (verify "- with multiple arguments"
     (- 3 2 1 -4)
     4))

 ;; Rebirth comparison procedures support two arguments
 (topic "comparison"
   (verify "= with two arguments"
     (and (= 5 5)
          (not (= 4 3)))
     #t)
   (verify "< with two arguments"
     (and (< 5 6)
          (not (< 6 4)))
     #t)
   (verify "> with two arguments"
     (and (> 5 4)
          (not (> 3 4)))
     #t)
   (verify "zero? with two arguments"
     (and (zero? 0)
          (not (zero? 5)))
     #t)
   (verify "eq? given the same object"
     (let ((x (list 1 2 3)))
       (eq? x x))
     #t)
   (verify "eq? given different but similar objects"
     (let ((x (list 1 2 3))
           (y (list 1 2 3)))
       (eq? x y))
     #f))

 (topic "if"
   (verify "if #t is truthy"
     (if #t 1)
     1)
   (verify "if #f is not truthy"
     (if #f #f 2)
     2)
   (verify "if non-empty string is truthy"
     (if "string" #t)
     #t)
   (verify "if empty string is truthy"
     (if "" #t)
     #t)
   (verify "if symbol is truthy"
     (if (quote symbol) #t)
     #t)
   (verify "if unspecified is truthy"
     (if (if #f #f) #t)
     #t)
   (verify "if short-circuits when true"
     (if #t #t (error "should not happen"))
     #t)
   (verify "if short-circuits when false"
     (if #f (error "should not happen") #t)
     #t))

 (topic "and"
   (verify "and nullary"
     (and)
     #t)
   (verify "and unary truthy"
     (and #t)
     #t)
   (verify "and unary false"
     (and #f)
     #f)
   (verify "and nary all truthy"
     (and #t "" 0 (lambda ()) (quote all))
     (quote all))
   (verify "and nary one false"
     (and #t #t #f)
     #f))

 (topic "or"
   (verify "or nullary"
     (or)
     #f)
   (verify "or unary truthy"
     (or #t)
     #t)
   (verify "or unary false"
     (or #f)
     #f)
   (verify "or nary one truthy"
     (or #f #f #f (quote any))
     (quote any))
   (verify "or nary all false"
     (or #f #f #f)
     #f))

 (topic "case"
   (verify "case with single clause predicate"
     (case #t
       ((#t) (quote ok)))
     (quote ok))
   (verify "case with multiple clause predicates"
     (case 5
       ((1 2 3 4 5) #t))
     #t)
   (verify "case with multiple clauses"
     (case #f
       ((#t) (quote t))
       ((#f) (quote f)))
     (quote f))
   (verify "case with else"
     (case 5
       ((#t) #f)
       (else (quote else)))
     (quote else)))

 (topic "append"
   (verify "append with no arguments"
     (append)
     (list))
   (verify "append with one list"
     (append (list 1 2))
     (list 1 2))
   (verify "append with multiple lists"
     (append (list 1 2) (list) (list 3 4 5))
     (list 1 2 3 4 5)))

 (topic "map"
   (verify "map with empty list"
     (map (lambda (_))
          (list))
     (list))
   (verify "map with non-empty list"
     (map (lambda (x) (+ 1 x))
          (list 1 2 3))
     (list 2 3 4))
   (verify "map with multiple lists"
     (map (lambda (x y) (+ x y))
          (list 1 2 3)
          (list 11 12 13))
     (list 12 14 16)))

 (topic "fold"
   (verify "fold with empty list"
     (fold (lambda (_ __))
           (list)
           (list))
     (list))
   ;; Rebirth's fold only supports one list
   (verify "fold with non-empty list"
     (fold (lambda (x y) (+ x y))
           0
           (list 1 2 3))
     6))

 ;; certain things (like es:defined?) cannot be tested here because compiler
 ;; procedures are not available at runtime
 (topic "es procedures/macros"
   (verify "es:null?"
     (and (es:null? es:null)
          (not (es:null? "")))
     #t)
   (verify "es:array? given list"
     (es:array? (list))
     #t)
   (verify "es:array? given non-list"
     (or (es:array? "")
         (es:array? #t)
         (es:array? 5)
         (es:array? es:array?))
     #f)
   (verify "es:error and es:try"
     (es:try (error "test")
             (lambda (e) (quote thrown)))
     (quote thrown))

   ;; these also verify that the given Scheme object is properly recognized
   ;; by Rebirth (and produces the intended internal representation)
   (verify "es:typeof on list"
     (es:typeof (list 1 2))
     "object")
   (verify "es:typeof on string"
     (es:typeof "string")
     "string")
   (verify "es:typeof on non-negative number"
     (es:typeof 1)
     "number")
   (verify "es:typeof on negative number"
     (es:typeof -1)
     "number")
   (verify "es:typeof on float"
     (es:typeof 1.5)
     "number")
   (verify "es:typeof on float with no preceding digit"
     (es:typeof .5)
     "number")
   (verify "es:typeof on negative float"
     (es:typeof -0.5)
     "number")
   (verify "es:typeof on negative float with no preceding digit"
     (es:typeof -.5)
     "number")
   (verify "es:typeof on #t"
     (es:typeof #t)
     "boolean")
   (verify "es:typeof on #f"
     (es:typeof #f)
     "boolean")
   (verify "es:typeof on procedure"
     (es:typeof (lambda ()))
     "function")
   (verify "es:typeof on symbol"
     (es:typeof (quote foo))
     "symbol")

   (verify "es:match with es:regexp"
     (and (es:match (es:regexp "^foo") "foobar")
          (not (es:match (es:regexp "^bar") "foobar")))
     #t)
   (verify "es:replace with string"
     (es:replace "foo" "bar" "foobar")
     "barbar")
   (verify "es:replace with es:regexp"
     (es:replace (es:regexp "^fo+") "q" "foobar")
     "qbar")

   (verify "es:while with predicate"
     (let ((x 3))
       (es:while (> x 1) (set! x (- x 1)))
       x)
     1)
   (verify "es:while with es:break"
     (let ((x 3))
       (es:while (> x 1)
                 (set! x (- x 1))
                 (es:break))
       x)
     2))

 (topic "eval and environment"
   (skip "eval in new environment"
     (eval (quote
            (let ((x 5))
              (+ x 5)))
           (null-environment 5))
     10)
   (skip "eval inheriting environment"
     (let ((x (quote xsym)))
       (eval (list x)
             (es:inherit-env)))
     (quote xsym))))