\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\     http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.

also ansi also internals

( Support for eval tests )
40000 constant expect-limit
create expect-buffer expect-limit allot
create result-buffer expect-limit allot
variable expect-used   variable result-used
: till;e ( -- n )
   begin >in @ bl parse dup 0= >r s" ;e" str= r> or if exit then drop again ;
: e: ( "name" -- ) create >in @
   till;e over - swap tib + swap dup , $place
   does> dup cell+ swap @ evaluate ;
: expect-emit ( ch -- ) expect-used @ expect-limit < assert
                        expect-buffer expect-used @ + c!
                        1 expect-used +! ;
: result-emit ( ch -- ) result-used @ expect-limit < assert
                        result-buffer result-used @ + c!
                        1 result-used +! ;
: expect-type ( a n -- ) for aft dup c@ expect-emit 1+ then next drop ;
: result-type ( a n -- ) for aft dup c@ result-emit 1+ then next drop ;
: expected ( -- a n ) expect-buffer expect-used @ ;
: resulted ( -- a n ) result-buffer result-used @ ;
: out:cr   13 expect-emit nl expect-emit ;
: out:\ ( "line" -- ) nl parse expect-type ;
: out: ( "line" -- ) out:\ out:cr ;
variable confirm-old-type
: confirm{   ['] type >body @ confirm-old-type ! ['] result-type is type ;
: }confirm   confirm-old-type @ is type ;
: expect-reset   0 expect-used ! 0 result-used ! ;
: diverged ( a n a n -- a n )
   begin
      dup 0= if 2drop exit then
      >r dup c@ >r rot dup c@ >r -rot r> r> <> r> swap if 2drop exit then
      >r >r dup 0= if rdrop rdrop exit then r> r>
      >r >r >r 1+ r> 1- r> 1+ r> 1-
   again
;
: stars ( n -- ) 1- for 42 emit next ;
: expect-finish   expected resulted str= if exit then }confirm
   cr ." Expected:" cr expected resulted diverged type 30 stars cr
      ." Resulted:" cr resulted expected diverged type 30 stars cr 1 throw ;

( Better error asserts )
: =assert ( actual expected -- )
  2dup <> if }confirm ."   FAILURE! EXPECTED: " .
                      ." ACTUAL: " . space 0 assert then 2drop ;
: <assert ( actual expected -- )
  2dup >= if }confirm ."   MUST BE LESS THAN: " .
                      ." ACTUAL: " . space 0 assert then 2drop ;
: >assert ( actual expected -- )
  2dup <= if }confirm ."   MUST BE GREATER THAN: " .
                      ." ACTUAL: " . space 0 assert then 2drop ;

( Input testing )
create in-buffer 1000 allot
variable in-head   variable in-tail
: >in ( c -- ) in-buffer in-head @ + c!  1 in-head +! ;
: in> ( -- c ) in-tail @ in-head @ <assert
               in-buffer in-tail @ + c@  1 in-tail +!
               in-head @ in-tail @ = if 0 in-head ! 0 in-tail ! then ;
: s>in ( a n -- ) for aft dup c@ >in 1+ then next drop ;
: in: ( "line" -- ) nl parse s>in nl >in ;
' in> is key

( Testing Framework )
( run-tests runs all words starting with "test-", use assert to assert things. )
variable tests-found   variable tests-run    variable tests-passed
: test? ( xt -- f ) >name s" test-" startswith? ;
: for-tests ( xt -- )
   context @ @ begin dup while dup test? if 2dup >r >r swap execute r> r> then >link repeat 2drop ;
: reset-test-counters   0 tests-found !   0 tests-run !   0 tests-passed ! ;
: count-test ( xt -- ) drop 1 tests-found +! ;
: check-fresh   depth if }confirm ."  DEPTH LEAK! " depth . 1 throw then
                fdepth if }confirm ."  FDEPTH LEAK! " fdepth . 1 throw then ;
: wrap-test ( xt -- ) expect-reset >r check-fresh r> execute check-fresh expect-finish ;
: red   1 fg ;   : green   2 fg ;   : hr   40 for [char] - emit next cr ;
: replace-line   13 emit clear-to-eol ;
: label-test ( xt -- ) replace-line >name type ;
: run-test ( xt -- ) dup label-test only forth confirm{ ['] wrap-test catch }confirm
   if drop ( cause xt restored on throw ) red ."  FAILED" normal cr
   else green ."  OK" normal 1 tests-passed +! then 1 tests-run +! ;
: show-test-results
   replace-line hr
   ."   PASSED: " green tests-passed @ . normal
   ."   RUN: " tests-run @ .
   ."   FOUND: " tests-found @ . cr
   tests-passed @ tests-found @ = if
     green ."   ALL TESTS PASSED" normal cr
   else
     ."   FAILED: " red tests-run @ tests-passed @ - . normal cr
   then hr ;
: run-tests
   reset-test-counters ['] count-test for-tests
   ['] run-test for-tests show-test-results
   tests-passed @ tests-found @ <> terminate ;
only forth
