factor/basis/prettyprint/prettyprint-tests.factor

USING: accessors arrays classes.intersection classes.maybe
classes.union compiler.units continuations definitions effects
eval generic generic.standard hashtables io io.streams.duplex
io.streams.string kernel listener make math namespaces parser
prettyprint prettyprint.config prettyprint.private
prettyprint.sections see sequences splitting
strings tools.continuations tools.continuations.private
tools.test vectors vocabs.parser words ;
IN: prettyprint.tests

[ "4" ] [ 4 unparse ] unit-test
[ "4096" ] [ 4096 unparse ] unit-test
[ "0b1000000000000" ] [ 2 number-base [ 4096 unparse ] with-variable ] unit-test
[ "0o10000" ] [ 8 number-base [ 4096 unparse ] with-variable ] unit-test
[ "0x1000" ] [ 16 number-base [ 4096 unparse ] with-variable ] unit-test
[ "1.0" ] [ 1.0 unparse ] unit-test
[ "8.0" ] [ 8.0 unparse ] unit-test
[ "8.0" ] [ 2 number-base [ 8.0 unparse ] with-variable ] unit-test
[ "8.0" ] [ 8 number-base [ 8.0 unparse ] with-variable ] unit-test
[ "0x1.0p3" ] [ 16 number-base [ 8.0 unparse ] with-variable ] unit-test
[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test

[ "+" ] [ \ + unparse ] unit-test

[ "\\ +" ] [ [ \ + ] first unparse ] unit-test

[ "{ }" ] [ { } unparse ] unit-test

[ "{ 1 2 3 }" ] [ { 1 2 3 } unparse ] unit-test

[ "\"hello\\\\backslash\"" ]
[ "hello\\backslash" unparse ]
unit-test

! [ "\"\\u123456\"" ]
! [ "\u123456" unparse ]
! unit-test

[ "\"\\e\"" ]
[ "\e" unparse ]
unit-test

[ "\"\\x01\"" ]
[ 1 1string unparse ]
unit-test

[ "f" ] [ f unparse ] unit-test
[ "t" ] [ t unparse ] unit-test

[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test

[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test

[ ] [ \ fixnum see ] unit-test

[ ] [ \ integer see ] unit-test

[ ] [ \ generic see ] unit-test

[ ] [ \ duplex-stream see ] unit-test

[ "[ \\ + ]" ] [ [ \ + ] unparse ] unit-test
[ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test
    
[ t ] [
    100 \ dup <array> unparse-short
    "{" head?
] unit-test

: foo ( a -- b ) dup * ; inline

[ "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" ]
[ [ \ foo see ] with-string-writer ] unit-test

: bar ( x -- y ) 2 + ;

[ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ]
[ [ \ bar see ] with-string-writer ] unit-test

: blah ( a a a a a a a a a a a a a a a a a a a a -- )
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop
    drop ;

[ "drop ;" ] [
    [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test

: check-see ( expect name -- ? )
    [
        [
            [ parse-fresh drop ] with-compilation-unit
            [
                "prettyprint.tests" lookup-word see
            ] with-string-writer "\n" split but-last
        ] keep =
    ] with-interactive-vocabs ;

GENERIC: method-layout ( a -- b )

M: complex method-layout
    drop
    "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
    ;

M: fixnum method-layout ;

M: integer method-layout ;

M: object method-layout ;

[
    {
        "USING: kernel math prettyprint.tests ;"
        "M: complex method-layout"
        "    drop"
        "    \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
        "    ;"
        ""
        "USING: math prettyprint.tests ;"
        "M: fixnum method-layout ;"
        ""
        "USING: math prettyprint.tests ;"
        "M: integer method-layout ;"
        ""
        "USING: kernel prettyprint.tests ;"
        "M: object method-layout ;"
        ""
    }
] [
    [ \ method-layout see-methods ] with-string-writer "\n" split
] unit-test

: soft-break-test ( -- str )
    {
        "USING: kernel math sequences strings ;"
        "IN: prettyprint.tests"
        ": soft-break-layout ( x y -- ? )"
        "    over string? ["
        "        over hashcode over hashcode number="
        "        [ sequence= ] [ 2drop f ] if"
        "    ] [ 2drop f ] if ;"
    } ;

[ t ] [
    "soft-break-layout" soft-break-test check-see
] unit-test

DEFER: parse-error-file

: another-soft-break-test ( -- str )
    {
        "USING: make sequences ;"
        "IN: prettyprint.tests"
        ": another-soft-break-layout ( node -- quot )"
        "    parse-error-file"
        "    [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
    } ;

[ t ] [
    "another-soft-break-layout" another-soft-break-test
    check-see
] unit-test

: string-layout ( -- str )
    {
        "USING: accessors debugger io kernel ;"
        "IN: prettyprint.tests"
        ": string-layout-test ( error -- )"
        "    \"Expected \" write dup want>> expected>string write"
        "    \" but got \" write got>> expected>string print ;"
    } ;


[ t ] [
    "string-layout-test" string-layout check-see
] unit-test

: narrow-test ( -- array )
    {
        "USING: arrays combinators continuations kernel sequences ;"
        "IN: prettyprint.tests"
        ": narrow-layout ( obj1 obj2 -- obj3 )"
        "    {"
        "        { [ dup continuation? ] [ append ] }"
        "        { [ dup not ] [ drop reverse ] }"
        "        { [ dup pair? ] [ [ remove! drop ] keep ] }"
        "    } cond ;"
    } ;

[ t ] [
    "narrow-layout" narrow-test check-see
] unit-test

: another-narrow-test ( -- array )
    {
        "IN: prettyprint.tests"
        ": another-narrow-layout ( -- obj )"
        "    H{"
        "        { 1 2 }"
        "        { 3 4 }"
        "        { 5 6 }"
        "        { 7 8 }"
        "        { 9 10 }"
        "        { 11 12 }"
        "        { 13 14 }"
        "    } ;"
    } ;

[ t ] [
    "another-narrow-layout" another-narrow-test check-see
] unit-test

IN: prettyprint.tests
TUPLE: class-see-layout ;

IN: prettyprint.tests
GENERIC: class-see-layout ( x -- y )

USING: prettyprint.tests ;
M: class-see-layout class-see-layout ;

[
    {
        "IN: prettyprint.tests"
        "TUPLE: class-see-layout ;"
        ""
        "IN: prettyprint.tests"
        "GENERIC: class-see-layout ( x -- y )"
        ""
    }
] [
    [ \ class-see-layout see ] with-string-writer "\n" split
] unit-test

[
    {
        "USING: prettyprint.tests ;"
        "M: class-see-layout class-see-layout ;"
        ""
    }
] [
    [ \ class-see-layout see-methods ] with-string-writer "\n" split
] unit-test

[ ] [ \ in>> synopsis drop ] unit-test

! Regression
[ t ] [
    "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
    dup eval( -- )
    "generic-decl-test" "prettyprint.tests" lookup-word
    [ see ] with-string-writer =
] unit-test

[ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test

[ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
 
[ [ 2 2 + . ] ] [
    [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test

[ [ 2 2 + . ] ] [
    [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test

GENERIC: generic-see-test-with-f ( obj -- obj )

M: f generic-see-test-with-f ;

[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
    [ M\ f generic-see-test-with-f see ] with-string-writer
] unit-test

PREDICATE: predicate-see-test < integer even? ;

[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
    [ \ predicate-see-test see ] with-string-writer
] unit-test

INTERSECTION: intersection-see-test sequence number ;

[ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
    [ \ intersection-see-test see ] with-string-writer
] unit-test

[ ] [ \ compose see ] unit-test
[ ] [ \ curry see ] unit-test

[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
    
TUPLE: started-out-hustlin' ;

GENERIC: ended-up-ballin' ( a -- b )

M: started-out-hustlin' ended-up-ballin' ; inline

[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
    [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
] unit-test

TUPLE: tuple-with-declared-slot { x integer } ;

[
    {
        "USING: math ;"
        "IN: prettyprint.tests"
        "TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
        ""
    }
] [
    [ \ tuple-with-declared-slot see ] with-string-writer "\n" split
] unit-test

TUPLE: tuple-with-read-only-slot { x read-only } ;

[
    {
        "IN: prettyprint.tests"
        "TUPLE: tuple-with-read-only-slot { x read-only } ;"
        ""
    }
] [
    [ \ tuple-with-read-only-slot see ] with-string-writer "\n" split
] unit-test

TUPLE: tuple-with-initial-slot { x initial: 123 } ;

[
    {
        "IN: prettyprint.tests"
        "TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
        ""
    }
] [
    [ \ tuple-with-initial-slot see ] with-string-writer "\n" split
] unit-test

TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;

[
    {
        "USING: math ;"
        "IN: prettyprint.tests"
        "TUPLE: tuple-with-initial-declared-slot"
        "    { x integer initial: 123 } ;"
        ""
    }
] [
    [ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
] unit-test

TUPLE: final-tuple ; final

[
    {
        "IN: prettyprint.tests"
        "TUPLE: final-tuple ; final"
        ""
    }
] [
    [ \ final-tuple see ] with-string-writer "\n" split
] unit-test

[ "H{ { 1 2 } }\n" ] [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test

[ "H{ { 1 ~array~ } }\n" ] [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test

[ "{ ~array~ }\n" ] [ [ { { 1 2 } } short. ] with-string-writer ] unit-test

[ "H{ { 1 { 2 3 } } }\n" ] [
    f nesting-limit [
        [ H{ { 1 { 2 3 } } } . ] with-string-writer
    ] with-variable
] unit-test

[ "maybe{ integer }\n" ] [ [  maybe{ integer } . ] with-string-writer ] unit-test
TUPLE: bob a b ;
[ "maybe{ bob }\n" ] [ [ maybe{ bob } . ] with-string-writer ] unit-test
[ "maybe{ word }\n" ] [ [ maybe{ word } . ] with-string-writer ] unit-test

TUPLE: har a ;
GENERIC: harhar ( obj -- obj )
M: maybe{ har } harhar ;
M: integer harhar M\ integer harhar drop ;
[
"""USING: prettyprint.tests ;
M: maybe{ har } harhar ;

USING: kernel math prettyprint.tests ;
M: integer harhar M\\ integer harhar drop ;\n"""
] [
    [ \ harhar see-methods ] with-string-writer
] unit-test

TUPLE: mo { a union{ float integer } } ;
TUPLE: fo { a intersection{ fixnum integer } } ;

[
"""USING: math ;
IN: prettyprint.tests
TUPLE: mo { a union{ integer float } initial: 0 } ;
"""
] [
    [ \ mo see ] with-string-writer
] unit-test

[
"""USING: math ;
IN: prettyprint.tests
TUPLE: fo { a intersection{ integer fixnum } initial: 0 } ;
"""
] [
    [ \ fo see ] with-string-writer
] unit-test

[
"""union{ intersection{ string hashtable } union{ integer float } }\n"""
] [ [ union{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test

[
"""intersection{
    intersection{ string hashtable }
    union{ integer float }
}
"""
] [ [ intersection{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test

[
"""maybe{ union{ integer float } }\n"""
] [
    [ maybe{ union{ float integer } } . ] with-string-writer
] unit-test

[
"""maybe{ maybe{ integer } }\n"""
] [
    [ maybe{ maybe{ integer } } . ] with-string-writer
] unit-test

{ "{ 0 1 2 3 4 }" } [
    [ 5 length-limit [ 5 iota >array pprint ] with-variable ]
    with-string-writer
] unit-test

{ "{ 0 1 2 3 ~2 more~ }" } [
    [ 5 length-limit [ 6 iota >array pprint ] with-variable ]
    with-string-writer
] unit-test

: margin-test ( number-of-'a's -- str )
    [
        [ CHAR: a <string> text "b" text ] with-pprint
    ] with-string-writer ;

[
"""aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b"""
] [ margin get 3 - margin-test ] unit-test

[
"""aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b"""
] [ margin get 2 - margin-test ] unit-test

[
"""aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
b"""
] [ margin get 1 - margin-test ] unit-test