More cleanups to require-all and unit tests
							parent
							
								
									c1dd7cf855
								
							
						
					
					
						commit
						9271da5070
					
				| 
						 | 
				
			
			@ -148,10 +148,17 @@ SYMBOL: load-help?
 | 
			
		|||
    dup update-roots
 | 
			
		||||
    dup modified-sources swap modified-docs ;
 | 
			
		||||
 | 
			
		||||
: load-error. ( vocab error -- )
 | 
			
		||||
    "==== " write >r
 | 
			
		||||
    dup vocab-name swap f >vocab-link write-object ":" print nl
 | 
			
		||||
    r> print-error ;
 | 
			
		||||
: vocab-heading. ( vocab -- )
 | 
			
		||||
    nl
 | 
			
		||||
    "==== " write
 | 
			
		||||
    dup vocab-name swap f >vocab-link write-object ":" print
 | 
			
		||||
    nl ;
 | 
			
		||||
 | 
			
		||||
: load-error. ( triple -- )
 | 
			
		||||
    dup first vocab-heading.
 | 
			
		||||
    dup second print-error
 | 
			
		||||
    drop ;
 | 
			
		||||
    ! third "Traceback" swap write-object ;
 | 
			
		||||
 | 
			
		||||
TUPLE: require-all-error vocabs ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -166,10 +173,14 @@ M: require-all-error summary
 | 
			
		|||
    dup length 1 = [ first require ] [
 | 
			
		||||
        [
 | 
			
		||||
            [
 | 
			
		||||
                [ [ require ] [ 2array , ] recover ] each
 | 
			
		||||
                [
 | 
			
		||||
                    [ require ]
 | 
			
		||||
                    [ error-continuation get 3array , ]
 | 
			
		||||
                    recover
 | 
			
		||||
                ] each
 | 
			
		||||
            ] { } make
 | 
			
		||||
            dup empty? [ drop ] [
 | 
			
		||||
                dup [ nl load-error. ] assoc-each
 | 
			
		||||
                dup [ load-error. nl ] each
 | 
			
		||||
                keys require-all-error
 | 
			
		||||
            ] if
 | 
			
		||||
        ] with-compiler-errors
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -11,7 +11,8 @@ SYMBOL: failures
 | 
			
		|||
: <failure> ( error what -- triple )
 | 
			
		||||
    error-continuation get 3array ;
 | 
			
		||||
 | 
			
		||||
: failure ( error what -- ) <failure> failures get push ;
 | 
			
		||||
: failure ( error what -- )
 | 
			
		||||
    <failure> failures get push ;
 | 
			
		||||
 | 
			
		||||
SYMBOL: this-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -45,16 +46,23 @@ M: expected-error summary
 | 
			
		|||
: ignore-errors ( quot -- )
 | 
			
		||||
    [ drop ] recover ; inline
 | 
			
		||||
 | 
			
		||||
: run-test ( path -- failures )
 | 
			
		||||
: (run-test) ( vocab -- )
 | 
			
		||||
    dup vocab-source-loaded? [
 | 
			
		||||
        vocab-tests-path dup [
 | 
			
		||||
            dup ?resource-path exists? [
 | 
			
		||||
                [ "temporary" forget-vocab ] with-compilation-unit
 | 
			
		||||
    [
 | 
			
		||||
                dup run-file
 | 
			
		||||
                [ dup forget-source ] with-compilation-unit
 | 
			
		||||
            ] when
 | 
			
		||||
        ] when
 | 
			
		||||
    ] when drop ;
 | 
			
		||||
 | 
			
		||||
: run-test ( vocab -- failures )
 | 
			
		||||
    V{ } clone [
 | 
			
		||||
        failures [
 | 
			
		||||
                [ run-file ] [ swap failure ] recover
 | 
			
		||||
            (run-test)
 | 
			
		||||
        ] with-variable
 | 
			
		||||
        ] keep
 | 
			
		||||
    ] keep
 | 
			
		||||
    [ forget-source ] with-compilation-unit ;
 | 
			
		||||
    ] keep ;
 | 
			
		||||
 | 
			
		||||
: failure. ( triple -- )
 | 
			
		||||
    dup second .
 | 
			
		||||
| 
						 | 
				
			
			@ -70,8 +78,7 @@ M: expected-error summary
 | 
			
		|||
        ] [
 | 
			
		||||
            "==== FAILING TESTS:" print
 | 
			
		||||
            [
 | 
			
		||||
                nl
 | 
			
		||||
                "Failing tests in " write swap <pathname> .
 | 
			
		||||
                swap vocab-heading.
 | 
			
		||||
                [ nl failure. nl ] each
 | 
			
		||||
            ] assoc-each
 | 
			
		||||
        ] if
 | 
			
		||||
| 
						 | 
				
			
			@ -79,19 +86,12 @@ M: expected-error summary
 | 
			
		|||
        drop "==== NOTHING TO TEST" print
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
: run-vocab-tests ( vocabs -- failures )
 | 
			
		||||
    dup empty? [ f ] [
 | 
			
		||||
: run-tests ( prefix -- failures )
 | 
			
		||||
    child-vocabs dup empty? [ f ] [
 | 
			
		||||
        [ dup run-test ] { } map>assoc
 | 
			
		||||
        [ second empty? not ] subset
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
: run-tests ( prefix -- failures )
 | 
			
		||||
    child-vocabs
 | 
			
		||||
    [ vocab-source-loaded? ] subset
 | 
			
		||||
    [ vocab-tests-path ] map
 | 
			
		||||
    [ dup [ ?resource-path exists? ] when ] subset
 | 
			
		||||
    run-vocab-tests ;
 | 
			
		||||
 | 
			
		||||
: test ( prefix -- )
 | 
			
		||||
    run-tests failures. ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue