tools.test: Working on crazy unit tests.

basis/tools/test/test-tests.factor

@@ -1,6 +1,7 @@
+USING: continuations debugger io io.errors io.streams.string
+kernel math multiline namespaces sequences tools.test
+tools.test.private ;
 IN: tools.test.tests
-USING: continuations debugger io.streams.string kernel namespaces
-sequences tools.test tools.test.private ;
 
 { 1 } [
     [
@@ -18,3 +19,17 @@ sequences tools.test tools.test.private ;
     create-test-failure [ error. ] with-string-writer
     "OBJ-CURRENT-THREAD" swap subseq?
 ] unit-test
+
+UNIT-TEST: [ 1 1 + ] { 2 }
+
+STDOUT-UNIT-TEST: [ "hello" write ] "hello"
+STDERR-UNIT-TEST: [ "hello" ewrite ] "hello"
+
+![[
+<UNIT-TEST-FAILED
+    UNIT-TEST-CODE: [ 1 1 + ]
+    GOT-STACK: { 2 }
+    EXPECTED-STACK: { 3 }
+    EXPECTED-STDOUT: "hello world"
+UNIT-TEST-FAILED>
+]]

basis/tools/test/test.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2003, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators command-line
-compiler.units continuations debugger effects fry
+compiler.units constructors continuations debugger effects fry
-generalizations io io.files.temp io.files.unique kernel lexer
+generalizations io io.files.temp io.files.unique
-locals macros math.functions math.vectors namespaces parser
+io.streams.string kernel lexer locals macros math.functions
-prettyprint quotations sequences sequences.generalizations
+math.vectors namespaces parser prettyprint quotations sequences
-source-files source-files.errors source-files.errors.debugger
+sequences.generalizations source-files source-files.errors
-splitting stack-checker summary system tools.errors unicode
+source-files.errors.debugger splitting stack-checker summary
-vocabs vocabs.files vocabs.metadata vocabs.parser words ;
+system tools.errors unicode vocabs vocabs.files vocabs.metadata
+vocabs.parser words ;
 FROM: vocabs.hierarchy => load ;
 IN: tools.test
 
@@ -238,6 +239,65 @@ SYNTAX: \UNIT-TEST:
         ] recover
     ] append! ;
 
+TUPLE: unit-test-failed-section quot ;
+CONSTRUCTOR: <unit-test-failed-section> unit-test-failed-section ( quot -- obj ) ;
+SYMBOL: UNIT-TEST-FAILED>
+SYNTAX: \<UNIT-TEST-FAILED
+    \ UNIT-TEST-FAILED> parse-until <unit-test-failed-section> suffix! ;
+
+TUPLE: unit-test-code quot ;
+CONSTRUCTOR: <unit-test-code> unit-test-code ( quot -- obj ) ;
+SYNTAX: \UNIT-TEST-CODE: scan-object <unit-test-code> suffix! ;
+
+TUPLE: got-stack stack ;
+CONSTRUCTOR: <got-stack> got-stack ( stack -- obj ) ;
+SYNTAX: \GOT-STACK: scan-object <got-stack> suffix! ;
+
+TUPLE: expected-stack stack ;
+CONSTRUCTOR: <expected-stack> expected-stack ( stack -- obj ) ;
+SYNTAX: \EXPECTED-STACK: scan-object <expected-stack> suffix! ;
+
+TUPLE: got-stdout string ;
+CONSTRUCTOR: <got-stdout> got-stdout ( string -- obj ) ;
+SYNTAX: \GOT-STDOUT: scan-object <got-stdout> suffix! ;
+
+TUPLE: got-stderr string ;
+CONSTRUCTOR: <got-stderr> got-stderr ( string -- obj ) ;
+SYNTAX: \GOT-STDERR: scan-object <got-stderr> suffix! ;
+
+TUPLE: expected-stdout string ;
+CONSTRUCTOR: <expected-stdout> expected-stdout ( string -- obj ) ;
+SYNTAX: \EXPECTED-STDOUT: scan-object <expected-stdout> suffix! ;
+
+TUPLE: expected-stderr string ;
+CONSTRUCTOR: <expected-stderr> expected-stderr ( string -- obj ) ;
+SYNTAX: \EXPECTED-STDERR: scan-object <expected-stderr> suffix! ;
+
+TUPLE: named-unit-test name test stack ;
+CONSTRUCTOR: <named-unit-test> named-unit-test ( name test stack -- obj ) ;
+SYNTAX: \NAMED-UNIT-TEST:
+    scan-new-word scan-object scan-object <named-unit-test> suffix! ;
+
+TUPLE: stdout-unit-test test string ;
+CONSTRUCTOR: <stdout-unit-test> stdout-unit-test ( test string -- obj ) ;
+
+: run-stdout-unit-test ( obj -- )
+    [ test>> '[ _ with-string-writer ] call( -- string ) ]
+    [ string>> ] bi assert-string= ; inline
+
+SYNTAX: \STDOUT-UNIT-TEST:
+    scan-object scan-object <stdout-unit-test> '[ _ run-stdout-unit-test ] append! ;
+
+TUPLE: stderr-unit-test test string ;
+CONSTRUCTOR: <stderr-unit-test> stderr-unit-test ( test string -- obj ) ;
+
+: run-stderr-unit-test ( obj -- )
+    [ test>> '[ _ with-error-string-writer ] call( -- string ) ]
+    [ string>> ] bi assert-string= ; inline
+
+SYNTAX: \STDERR-UNIT-TEST:
+    scan-object scan-object <stderr-unit-test> '[ _ run-stderr-unit-test ] append! ;
+
 M: test-failure error. ( error -- )
     {
         [ error-location print nl ]

extra/syntax/extras/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/syntax/extras/extras-tests.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2017 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test syntax.extras ;
+IN: syntax.extras.tests
+
+<ARRAY: nums1 1 2 3 ;ARRAY>
+CONSTANT: nums2 <array 1 2 3 array>
+
+UNIT-TEST: [ nums1 ] { { 1 2 3 } }
+UNIT-TEST: [ nums2 ] { { 1 2 3 } }
+

extra/syntax/extras/extras.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2017 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays parser sequences vectors words.constant ;
+IN: syntax.extras
+
+SYMBOL: \ARRAY>
+SYNTAX: \<ARRAY \ARRAY> parse-until >array suffix! ;
+
+SYMBOL: \array>
+SYNTAX: \<array \array> parse-until >array suffix! ;
+
+
+SYMBOL: \;ARRAY>
+SYNTAX: \<ARRAY:
+    scan-new-word \;ARRAY> parse-until >array define-constant ;
+
+SYMBOL: \VECTOR>
+SYNTAX: \<VECTOR \VECTOR> parse-until >vector suffix! ;
+
+SYMBOL: \;VECTOR>
+SYNTAX: \<VECTOR:
+    scan-new-word \;VECTOR> parse-until >vector define-constant ;