factor/core/generic/standard/standard-tests.factor

USING: tools.test math math.functions math.constants
generic.standard generic.single strings sequences arrays kernel
accessors words byte-arrays bit-arrays parser namespaces make
quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval
classes.union classes.tuple compiler.units io.streams.string
compiler.crossref math.order ;
QUALIFIED-WITH: alien.c-types c
FROM: namespaces => set ;
SPECIALIZED-VECTOR: c:double
IN: generic.standard.tests

GENERIC: class-of ( x -- y )

M: fixnum class-of drop "fixnum" ;
M: word   class-of drop "word"   ;

[ "fixnum" ] [ 5 class-of ] unit-test
[ "word" ] [ \ class-of class-of ] unit-test
[ 3.4 class-of ] must-fail

GENERIC: foobar ( x -- y )
M: object foobar drop "Hello world" ;
M: fixnum foobar drop "Goodbye cruel world" ;

[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test

GENERIC: lo-tag-test ( obj -- obj' )

M: integer lo-tag-test 3 + ;
M: float lo-tag-test 4 - ;
M: rational lo-tag-test 2 - ;
M: complex lo-tag-test sq ;

[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test

GENERIC: hi-tag-test ( obj -- obj' )

M: string hi-tag-test ", in bed" append ;
M: integer hi-tag-test 3 + ;
M: array hi-tag-test [ hi-tag-test ] map ;
M: sequence hi-tag-test reverse ;

[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test

[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test

[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test

UNION: funnies quotation float complex ;

GENERIC: funny ( x -- y )
M: funnies funny drop 2 ;
M: object funny drop 0 ;

GENERIC: union-containment ( x -- y )
M: integer union-containment drop 1 ;
M: number union-containment drop 2 ;

[ 1 ] [ 1 union-containment ] unit-test
[ 2 ] [ 1.0 union-containment ] unit-test

[ 2 ] [ [ { } ] funny ] unit-test
[ 0 ] [ { } funny ] unit-test

TUPLE: shape ;

TUPLE: abstract-rectangle < shape width height ;

TUPLE: rectangle < abstract-rectangle ;

C: <rectangle> rectangle

TUPLE: parallelogram < abstract-rectangle skew ;

C: <parallelogram> parallelogram

TUPLE: circle < shape radius ;

C: <circle> circle

GENERIC: area ( shape -- n )

M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;

M: circle area radius>> sq pi * ;

[ 12 ] [ 4 3 <rectangle> area ] unit-test
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test

GENERIC: perimiter ( shape -- n )

: rectangle-perimiter ( l w -- n ) + 2 * ;

M: rectangle perimiter
    [ width>> ] [ height>> ] bi
    rectangle-perimiter ;

: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;

M: parallelogram perimiter
    [ width>> ]
    [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
    rectangle-perimiter ;

M: circle perimiter 2 * pi * ;

[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test

PREDICATE: very-funny < funnies number? ;

GENERIC: gooey ( x -- y )
M: very-funny gooey sq ;

[ 0.25 ] [ 0.5 gooey ] unit-test

GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
C: <for-arguments-sake> for-arguments-sake

M: for-arguments-sake empty-method-test drop "Hi" ;

TUPLE: another-one ;
C: <another-one> another-one

[ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
[ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test

GENERIC: big-mix-test ( obj -- obj' )

M: object big-mix-test drop "object" ;

M: tuple big-mix-test drop "tuple" ;

M: integer big-mix-test drop "integer" ;

M: float big-mix-test drop "float" ;

M: complex big-mix-test drop "complex" ;

M: string big-mix-test drop "string" ;

M: array big-mix-test drop "array" ;

M: sequence big-mix-test drop "sequence" ;

M: rectangle big-mix-test drop "rectangle" ;

M: parallelogram big-mix-test drop "parallelogram" ;

M: circle big-mix-test drop "circle" ;

[ "integer" ] [ 3 big-mix-test ] unit-test
[ "float" ] [ 5.0 big-mix-test ] unit-test
[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
[ "string" ] [ "hello" big-mix-test ] unit-test
[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test

GENERIC: small-lo-tag ( obj -- obj )

M: fixnum small-lo-tag drop "fixnum" ;

M: string small-lo-tag drop "string" ;

M: array small-lo-tag drop "array" ;

M: double-array small-lo-tag drop "double-array" ;

M: byte-array small-lo-tag drop "byte-array" ;

[ "fixnum" ] [ 3 small-lo-tag ] unit-test

[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test

! Testing recovery from bad method definitions
"IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- )
[
    "IN: generic.standard.tests M: dictionary unhappy ;" eval( -- )
] must-fail
[ ] [ "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test

GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ;
M: object complex-combination nip ;

[ "hi" ] [ "hi" 3 complex-combination ] unit-test
[ "hi" ] [ 3 "hi" complex-combination ] unit-test

! Regression
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;

GENERIC: wii ( x -- y )
M: both wii drop 3 ;
M: second-one wii drop 4 ;
M: tuple-class wii drop 5 ;
M: integer wii drop 6 ;

[ 3 ] [ T{ first-one } wii ] unit-test

GENERIC: tag-and-f ( x -- x x )

M: fixnum tag-and-f 1 ;

M: bignum tag-and-f 2 ;

M: float tag-and-f 3 ;

M: f tag-and-f 4 ;

[ f 4 ] [ f tag-and-f ] unit-test

[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test

! Issues with forget
GENERIC: generic-forget-test ( a -- b )

M: f generic-forget-test ;

[ ] [ \ f \ generic-forget-test method "m" set ] unit-test

[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test

[ ] [ "IN: generic.standard.tests M: f generic-forget-test ;" eval( -- ) ] unit-test

[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test

[ f ] [ f generic-forget-test ] unit-test

! erg's regression
[ ] [
    """IN: generic.standard.tests

    GENERIC: jeah ( a -- b )
    TUPLE: boii ;
    M: boii jeah ;
    GENERIC: jeah* ( a -- b )
    M: boii jeah* jeah ;""" eval( -- )

    """IN: generic.standard.tests
    FORGET: boii""" eval( -- )
    
    """IN: generic.standard.tests
    TUPLE: boii ;
    M: boii jeah ;""" eval( -- )
] unit-test

! Testing next-method
TUPLE: person ;

TUPLE: intern < person ;

TUPLE: employee < person ;

TUPLE: tape-monkey < employee ;

TUPLE: manager < employee ;

TUPLE: junior-manager < manager ;

TUPLE: middle-manager < manager ;

TUPLE: senior-manager < manager ;

TUPLE: executive < senior-manager ;

TUPLE: ceo < executive ;

GENERIC: salary ( person -- n )

M: intern salary
    #! Intentional mistake.
    call-next-method ;

M: employee salary drop 24000 ;

M: manager salary call-next-method 12000 + ;

M: middle-manager salary call-next-method 5000 + ;

M: senior-manager salary call-next-method 15000 + ;

M: executive salary call-next-method 2 * ;

M: ceo salary
    #! Intentional error.
    drop 5 call-next-method 3 * ;

[ salary ] must-infer

[ 24000 ] [ employee boa salary ] unit-test

[ 24000 ] [ tape-monkey boa salary ] unit-test

[ 36000 ] [ junior-manager boa salary ] unit-test

[ 41000 ] [ middle-manager boa salary ] unit-test

[ 51000 ] [ senior-manager boa salary ] unit-test

[ 102000 ] [ executive boa salary ] unit-test

[ ceo boa salary ]
[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with

[ intern boa salary ]
[ no-next-method? ] must-fail-with

! Weird shit
TUPLE: a ;
TUPLE: b ;
TUPLE: c ;

UNION: x a b ;
UNION: y a c ;

UNION: z x y ;

GENERIC: funky* ( obj -- )

M: z funky* "z" , drop ;

M: x funky* "x" , call-next-method ;

M: y funky* "y" , call-next-method ;

M: a funky* "a" , call-next-method ;

M: b funky* "b" , call-next-method ;

M: c funky* "c" , call-next-method ;

: funky ( obj -- seq ) [ funky* ] { } make ;

[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test

[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test

[ t ] [
    T{ a } funky
    { { "a" "x" "z" } { "a" "y" "z" } } member?
] unit-test

! Changing method combination should not fail
[ ] [ "IN: generic.standard.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
[ ] [ "IN: generic.standard.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test

[ f ] [ "xyz" "generic.standard.tests" lookup pic-def>> ] unit-test
[ f ] [ "xyz" "generic.standard.tests" lookup "decision-tree" word-prop ] unit-test

! Corner case
[ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ]
must-fail-with

! Generic words cannot be inlined
[ ] [ "IN: generic.standard.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
[ "IN: generic.standard.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail

! Moving a method from one vocab to another didn't always work
GENERIC: move-method-generic ( a -- b )

[ ] [ "IN: generic.standard.tests.a USE: strings USE: generic.standard.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test

[ ] [ "IN: generic.standard.tests.b USE: strings USE: generic.standard.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test

[ ] [ "IN: generic.standard.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test

[ { string } ] [ \ move-method-generic order ] unit-test

! FORGET: on method wrappers
GENERIC: forget-test ( a -- b )

M: integer forget-test 3 + ;

[ ] [ "IN: generic.standard.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test

[ { } ] [
    \ + effect-dependencies-of keys [ method? ] filter
    [ "method-generic" word-prop \ forget-test eq? ] filter
] unit-test

[ 10 forget-test ] [ no-method? ] must-fail-with

! Declarations on methods
GENERIC: flushable-generic ( a -- b ) flushable
M: integer flushable-generic ;

[ t ] [ \ flushable-generic flushable? ] unit-test
[ t ] [ M\ integer flushable-generic flushable? ] unit-test

GENERIC: non-flushable-generic ( a -- b )
M: integer non-flushable-generic ; flushable

[ f ] [ \ non-flushable-generic flushable? ] unit-test
[ t ] [ M\ integer non-flushable-generic flushable? ] unit-test

! method-for-object and method-for-class
GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;

[ t ] [
    reversed \ foozul method-for-class
    reversed \ foozul method
    eq?
] unit-test

[ t ] [
    fixnum \ <=> method-for-class
    real \ <=> method
    eq?
] unit-test