factor/unfinished/stack-checker/stack-checker-tests.factor

USING: accessors arrays generic stack-checker
stack-checker.backend stack-checker.errors kernel classes
kernel.private math math.parser math.private namespaces
namespaces.private parser sequences strings vectors words
quotations effects tools.test continuations generic.standard
sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators eval ;
IN: stack-checker.tests

: short-effect ( effect -- pair )
    [ in>> length ] [ out>> length ] bi 2array ;

: must-infer-as ( effect quot -- )
    >r 1quotation r> [ infer short-effect ] curry unit-test ;

: must-infer ( word/quot -- )
    dup word? [ 1quotation ] when
    [ infer drop ] curry [ ] swap unit-test ;

\ infer. must-infer

{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as

{ 1 2 } [ [ dup ] call ] must-infer-as
[ [ call ] infer ] must-fail

{ 2 4 } [ 2dup ] must-infer-as

{ 1 0 } [ [ ] [ ] if ] must-infer-as
[ [ if ] infer ] must-fail
[ [ [ ] if ] infer ] must-fail
[ [ [ 2 ] [ ] if ] infer ] must-fail
{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as

{ 4 3 } [
    [
        [ swap 3 ] [ nip 5 5 ] if
    ] [
        -rot
    ] if
] must-infer-as

{ 1 1 } [ dup [ ] when ] must-infer-as
{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as

{ 1 0 } [ [ drop ] when* ] must-infer-as
{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as

{ 0 1 }
[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as

[
    [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
] must-fail

! Test inference of termination of control flow
: termination-test-1 ( -- * ) "foo" throw ;

: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;

{ 1 1 } [ termination-test-2 ] must-infer-as

: simple-recursion-1 ( obj -- obj )
    dup [ simple-recursion-1 ] [ ] if ;

{ 1 1 } [ simple-recursion-1 ] must-infer-as

: simple-recursion-2 ( obj -- obj )
    dup [ ] [ simple-recursion-2 ] if ;

{ 1 1 } [ simple-recursion-2 ] must-infer-as

: bad-recursion-2 ( obj -- obj )
    dup [ dup first swap second bad-recursion-2 ] [ ] if ;

[ [ bad-recursion-2 ] infer ] must-fail

: funny-recursion ( obj -- obj )
    dup [ funny-recursion 1 ] [ 2 ] if drop ;

{ 1 1 } [ funny-recursion ] must-infer-as

! Simple combinators
{ 1 2 } [ [ first ] keep second ] must-infer-as

! Mutual recursion
DEFER: foe

: fie ( element obj -- ? )
    dup array? [ foe ] [ eq? ] if ;

: foe ( element tree -- ? )
    dup [
        2dup first fie [
            nip
        ] [
            second dup array? [
                foe
            ] [
                fie
            ] if
        ] if
    ] [
        2drop f
    ] if ;

{ 2 1 } [ fie ] must-infer-as
{ 2 1 } [ foe ] must-infer-as

: nested-when ( -- )
    t [
        t [
            5 drop
        ] when
    ] when ;

{ 0 0 } [ nested-when ] must-infer-as

: nested-when* ( obj -- )
    [
        [
            drop
        ] when*
    ] when* ;

{ 1 0 } [ nested-when* ] must-infer-as

SYMBOL: sym-test

{ 0 1 } [ sym-test ] must-infer-as

: terminator-branch ( a -- b )
    dup [
        length
    ] [
        "foo" throw
    ] if ;

{ 1 1 } [ terminator-branch ] must-infer-as

: recursive-terminator ( obj -- )
    dup [
        recursive-terminator
    ] [
        "Hi" throw
    ] if ;

{ 1 0 } [ recursive-terminator ] must-infer-as

GENERIC: potential-hang ( obj -- obj )
M: fixnum potential-hang dup [ potential-hang ] when ;

[ ] [ [ 5 potential-hang ] infer drop ] unit-test

TUPLE: funny-cons car cdr ;
GENERIC: iterate ( obj -- )
M: funny-cons iterate funny-cons-cdr iterate ;
M: f iterate drop ;
M: real iterate drop ;

{ 1 0 } [ iterate ] must-infer-as

! Regression
: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
{ 3 0 } [ dog ] must-infer-as

! Regression
DEFER: monkey
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
{ 3 0 } [ friend ] must-infer-as

! Regression -- same as above but we infer the second word first
DEFER: blah2
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
{ 3 0 } [ blah2 ] must-infer-as

! Regression
DEFER: blah4
: blah3 ( a b c -- )
    dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
: blah4 ( a b c -- )
    dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
{ 3 0 } [ blah4 ] must-infer-as

! Regression
: bad-combinator ( obj quot: ( -- ) -- )
    over [
        2drop
    ] [
        [ swap slip ] keep swap bad-combinator
    ] if ; inline recursive

[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail

! Regression
{ 2 2 } [
    dup string? [ 2array throw ] unless
    over string? [ 2array throw ] unless
] must-infer-as

! Regression

! This order of branches works
DEFER: do-crap
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
[ [ do-crap ] infer ] must-fail

! This one does not
DEFER: do-crap*
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
[ [ do-crap* ] infer ] must-fail

! Regression
: too-deep ( a b -- c )
    dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
{ 2 1 } [ too-deep ] must-infer-as

! Error reporting is wrong
MATH: xyz ( a b -- c )
M: fixnum xyz 2array ;
M: float xyz
    [ 3 ] bi@ swapd >r 2array swap r> 2array swap ;

[ [ xyz ] infer ] [ inference-error? ] must-fail-with

! Doug Coleman discovered this one while working on the
! calendar library
DEFER: A
DEFER: B
DEFER: C

: A ( a -- )
    dup {
        [ drop ]
        [ A ]
        [ \ A no-method ]
        [ dup C A ]
    } dispatch ;

: B ( b -- )
    dup {
        [ C ]
        [ B ]
        [ \ B no-method ]
        [ dup B B ]
    } dispatch ;

: C ( c -- )
    dup {
        [ A ]
        [ C ]
        [ \ C no-method ]
        [ dup B C ]
    } dispatch ;

{ 1 0 } [ A ] must-infer-as
{ 1 0 } [ B ] must-infer-as
{ 1 0 } [ C ] must-infer-as

! I found this bug by thinking hard about the previous one
DEFER: Y
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
: Y ( a b -- c d ) X ;

{ 2 2 } [ X ] must-infer-as
{ 2 2 } [ Y ] must-infer-as

! This one comes from UI code
DEFER: #1
: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
: #3 ( a -- ) [ #1 ] #2 ;
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;

[ \ #4 def>> infer ] must-fail
[ [ #1 ] infer ] must-fail

! Similar
DEFER: bar
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;

[ [ foo ] infer ] must-fail

[ 1234 infer ] must-fail

! This used to hang
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with

: m dup call ; inline

[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with

: m' dup curry call ; inline

[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with

: m'' [ dup curry ] ; inline

: m''' m'' call call ; inline

[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with

: m-if t over if ; inline

[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with

! This doesn't hang but it's also an example of the
! undedicable case
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
[ inference-error? ] must-fail-with

! This form should not have a stack effect

: bad-recursion-1 ( a -- b )
    dup [ drop bad-recursion-1 5 ] [ ] if ;

[ [ bad-recursion-1 ] infer ] must-fail

: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer ] must-fail

[ [ r> ] infer ] [ inference-error? ] must-fail-with

! Regression
[ [ cleave ] infer ] [ inference-error? ] must-fail-with

! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as

{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as

[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail

! Test number protocol
\ bitor must-infer
\ bitand must-infer
\ bitxor must-infer
\ mod must-infer
\ /i must-infer
\ /f must-infer
\ /mod must-infer
\ + must-infer
\ - must-infer
\ * must-infer
\ / must-infer
\ < must-infer
\ <= must-infer
\ > must-infer
\ >= must-infer
\ number= must-infer

! Test object protocol
\ = must-infer
\ clone must-infer
\ hashcode* must-infer

! Test sequence protocol
\ length must-infer
\ nth must-infer
\ set-length must-infer
\ set-nth must-infer
\ new must-infer
\ new-resizable must-infer
\ like must-infer
\ lengthen must-infer

! Test assoc protocol
\ at* must-infer
\ set-at must-infer
\ new-assoc must-infer
\ delete-at must-infer
\ clear-assoc must-infer
\ assoc-size must-infer
\ assoc-like must-infer
\ assoc-clone-like must-infer
\ >alist must-infer
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as

! Test some random library words
\ 1quotation must-infer
\ string>number must-infer
\ get must-infer

\ push must-infer
\ append must-infer
\ peek must-infer

\ reverse must-infer
\ member? must-infer
\ remove must-infer
\ natural-sort must-infer

\ forget must-infer
\ define-class must-infer
\ define-tuple-class must-infer
\ define-union-class must-infer
\ define-predicate-class must-infer
\ instance? must-infer
\ next-method-quot must-infer

! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as

\ dispose must-infer

! Test stream protocol
\ set-timeout must-infer
\ stream-read must-infer
\ stream-read1 must-infer
\ stream-readln must-infer
\ stream-read-until must-infer
\ stream-write must-infer
\ stream-write1 must-infer
\ stream-nl must-infer
\ stream-format must-infer
\ stream-write-table must-infer
\ stream-flush must-infer
\ make-span-stream must-infer
\ make-block-stream must-infer
\ make-cell-stream must-infer

! Test stream utilities
\ lines must-infer
\ contents must-infer

! Test prettyprinting
\ . must-infer
\ short. must-infer
\ unparse must-infer

\ describe must-infer
\ error. must-infer

! Test odds and ends
\ io-thread must-infer

! Incorrect stack declarations on inline recursive words should
! be caught
: fooxxx ( a b -- c ) over [ foo ] when ; inline
: barxxx ( a b -- c ) fooxxx ;

[ [ barxxx ] infer ] must-fail

! A typo
{ 1 0 } [ { [ ] } dispatch ] must-infer-as

DEFER: inline-recursive-2
: inline-recursive-1 ( -- ) inline-recursive-2 ;
: inline-recursive-2 ( -- ) inline-recursive-1 ;

{ 0 0 } [ inline-recursive-1 ] must-infer-as

! Hooks
SYMBOL: my-var
HOOK: my-hook my-var ( -- x )

M: integer my-hook "an integer" ;
M: string my-hook "a string" ;

{ 0 1 } [ my-hook ] must-infer-as

DEFER: deferred-word

{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as


DEFER: an-inline-word

: normal-word-3 ( -- )
    3 [ [ 2 + ] curry ] an-inline-word call drop ;

: normal-word-2 ( -- )
    normal-word-3 ;

: normal-word ( x -- x )
    dup [ normal-word-2 ] when ;

: an-inline-word ( obj quot -- )
    >r normal-word r> call ; inline

{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as

{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as

ERROR: custom-error ;

[ T{ effect f 0 0 t } ] [
    [ custom-error ] infer
] unit-test

: funny-throw throw ; inline

[ T{ effect f 0 0 t } ] [
    [ 3 funny-throw ] infer
] unit-test

[ T{ effect f 0 0 t } ] [
    [ custom-error inference-error ] infer
] unit-test

[ T{ effect f 1 1 t } ] [
    [ dup >r 3 throw r> ] infer
] unit-test

! This was a false trigger of the undecidable quotation
! recursion bug
{ 2 1 } [ find-last-sep ] must-infer-as

! Regression
: missing->r-check >r ;

[ [ missing->r-check ] infer ] must-fail

! Corner case
[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail

[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail

: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline

[ [ erg's-inference-bug ] infer ] must-fail

: inference-invalidation-a ( -- ) ;
: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline

[ 7 ] [ 4 3 inference-invalidation-c ] unit-test

{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as

[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test

[ 3 ] [ inference-invalidation-c ] unit-test

{ 0 1 } [ inference-invalidation-c ] must-infer-as

GENERIC: inference-invalidation-d ( obj -- )

M: object inference-invalidation-d inference-invalidation-c 2drop ;

\ inference-invalidation-d must-infer

[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test

[ [ inference-invalidation-d ] infer ] must-fail

: bad-recursion-3 ( -- ) dup [ >r bad-recursion-3 r> ] when ; inline
[ [ bad-recursion-3 ] infer ] must-fail

: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail

: bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
[ [ f [ ] bad-recursion-5 ] infer ] must-fail

: bad-recursion-6 ( quot: ( -- ) -- )
    dup bad-recursion-6 call ; inline recursive
[ [ [ drop f ] bad-recursion-6 ] infer ] must-fail

{ 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
{ 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as