Quick Test for Rebol

quick-test.reb

REBOL [
	Title:   "Simple testing framework"
	Author:  "Peter W A Wood"
	File: 	 %quick-test.reb
	Version: 0.1.1
	Rights:  "Copyright (C) 2011-2016 Peter W A Wood. All rights reserved."
	License: "BSD-3"
]

qt: make object! [
    
    ;; switches
    batch: false
    logging: false
    quiet: false
    
    ;; set up alternate print functions
    sys-print: :print
    sys-prin: :prin
    
    ;; set-up alternative now
    sys-now: :now
    
    test-prin: func [v] [
        unless batch [sys-prin v]
        if logging [write-log v]
    ]
    output: copy ""
    set 'print func [v][append output rejoin [v "^/"]]
    set 'prin func [v][append output reduce v]
    
    ;; set up log
    sys-write: :write
    log-file: join system/options/home %qt.log
    write-log: func[v][
        sys-write/append log-file v 
    ]
    
    ;; text fields
    run-name:     copy ""
    file-name:    copy ""
    group-name:   copy ""
    test-name:    copy ""
    
    ;; counters
    data: make object! [
        tests:    0
        passes:   0 
        failures: 0
    ]
    run: make data []
    file: make data []
    asserts: make data []
  
    ;; group switches
    group-name-not-prined: true
    group?: false
    
    ;; helper functions
    
    end-test: does [
        either equal? asserts/failures 0 [
            file/passes: file/passes + 1
        ][
            file/failures: file/failures + 1
        ]
    ]
  
    init-group: does [
        group-name-not-prined: true
        group?: false
        group-name: ""
    ]
  
    init-data: func [
      data [object!]
    ][
      data/tests: 0
      data/passes: 0
      data/failures: 0
    ]
    
    init-run: does [
      init-data run
      init-group
      if logging [sys-write log-file ""]
    ]
    
    init-file: does [
      init-data file
      init-group
    ]
    
    print-totals: func [
      data [object!]
    ][
        test-prin compose ["  Number of Tests Performed: " (data/tests) "^/"]
        test-prin compose ["  Number of Tests Passed:    " (data/passes) "^/"]
        test-prin compose ["  Number of Tests Failed:    " (data/failures) "^/"]
        if data/failures <> 0 [
            test-prin ["****************TEST FAILURES****************" "^/"]
        ]
    ]
      
    ;; testing dialect functions
    
    start-file: func [
      title [string!]
    ][
      init-file
      test-prin compose ["~~~Started Test~~~ " (title) "^/"]
      file-name: title
      group?: false
      init-data asserts
    ]
    
    start-group: func [
      title [string!]
    ][
      group-name: title
      group?: true
    ]
    
    start-test: func [
      title [string!]
    ][
      unless equal? file/tests 0 [end-test]
      test-name: title
      file/tests: file/tests + 1
      output: copy ""
      init-data asserts
    ]
    
    assert: func [
        assertion [logic!]
    ][
        asserts/tests: asserts/tests + 1
        either assertion [
            asserts/passes: asserts/passes + 1
        ][
            asserts/failures: asserts/failures + 1
            if group? [  
                if group-name-not-prined [
                    test-prin compose ["^/" "===group=== " (group-name) "^/"]
                    group-name-not-prined: false
                ]
            ]
            test-prin compose["--test-- " (test-name) " assertion " (asserts/tests)
                       " FAILED**************" "^/"]
            
        ]
    ]
    
    assert-printed?: func [msg] [
      assert found? find output msg
    ]
    
    assert~=: func[
        x    [number!]
        y    [number!]
        e    [number!]
        /local
        diff e1 e2
    ][
        ;; calculate tolerance to use
        ;;    as e * max (1, x, y)
        either x > 0.0 [
          e1: x * e
        ][
          e1: -1.0 * x * e
        ]
        if e > e1 [e1: e]
        either y > 0.0 [
          e2: y * e
        ][
          e2: -1.0 * y * e
        ]
        if e1 > e2 [e2: e1]
        
        ;; perform almost equal check
        either x > y [
          diff: x - y
        ][
          diff: y - x
        ]
        either diff > e2 [
          assert false
        ][
          assert true
        ]
    ]
    
    end-group: func [] [
      init-group
    ]
    
    end-file: func [] [
      if 0 <> (asserts/passes + asserts/failures) [end-test]  ; end last test
      test-prin compose ["~~~Finished Test~~~ " (file-name) "^/"]
      print-totals file
      test-prin "^/"
      
      ;; update run totals
      run/passes: run/passes + file/passes
      run/failures: run/failures + file/failures
      run/tests: run/tests + file/tests
    ]
  
    ;; test runner dialect functions
    
    set-log-file: func [log-file [file!]] [
        qt/log-file: log-file
    ]
    
    start-run: func [
        title [string!]
    ][
      init-run
      run-name: title
      test-prin compose ["***Started*** " (title) " at " (qt/sys-now/precise) "^/" "^/"]
    ]
    
    start-run-batch: func [
        title [string!]
    ][
      batch: true
      logging: true
      start-run title
    ]
    
    run-test: func[ file [file!]][
        do file    
    ]
    
    end-run: func [][
        test-prin compose ["***Finished*** " (run-name) " at " (qt/sys-now/precise) "^/"]
        print-totals run
        set 'print :sys-print
        set 'prin :sys-prin
        set 'now :sys-now
        if logging [logging: false]
        if batch [
            batch: false
            quit/return min run/failures 1
        ]
    ]
    
    ;; create the testing "dialect"
    set '~~~start-file~~~       :start-file
    set '===start-group===      :start-group
    set '--test--               :start-test
    set '--assert               :assert
    set '--assert-printed?      :assert-printed?
    set '--assert~=             :assert~=
    set '===end-group===        :end-group
    set '~~~end-file~~~         :end-file
    
    ;; create the test runner "dialect"
    set '--set-log-file         :set-log-file
    set '***start-run***        :start-run
    set '***start-run-batch***  :start-run-batch
    set '--run-test             :run-test
    set '***end-run***          :end-run
    
]