factor/core/parser/parser-tests.factor

USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files assocs
sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger
vocabs vocabs.loader accessors eval combinators lexer
vocabs.parser words.symbol ;
IN: parser.tests

\ run-file must-infer

[
    [ 1 [ 2 [ 3 ] 4 ] 5 ]
    [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
    unit-test

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

    [ "hello world" ]
    [ "\"hello world\"" eval ]
    unit-test

    [ "\n\r\t\\" ]
    [ "\"\\n\\r\\t\\\\\"" eval ]
    unit-test

    [ "hello world" ]
    [
        "IN: parser.tests : hello \"hello world\" ;"
        eval "USE: parser.tests hello" eval
    ] unit-test

    [ ]
    [ "! This is a comment, people." eval ]
    unit-test

    ! Test escapes

    [ " " ]
    [ "\"\\u000020\"" eval ]
    unit-test

    [ "'" ]
    [ "\"\\u000027\"" eval ]
    unit-test

    ! Test EOL comments in multiline strings.
    [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test

    [ word ] [ \ f class ] unit-test

    ! Test stack effect parsing

    : effect-parsing-test ( a b -- c ) + ;

    [ t ] [
        "effect-parsing-test" "parser.tests" lookup
        \ effect-parsing-test eq?
    ] unit-test

    [ T{ effect f { "a" "b" } { "c" } f } ]
    [ \ effect-parsing-test "declared-effect" word-prop ] unit-test

    : baz ( a b -- * ) 2array throw ;

    [ t ]
    [ \ baz "declared-effect" word-prop terminated?>> ]
    unit-test

    [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test

    [ t ] [
        "effect-parsing-test" "parser.tests" lookup
        \ effect-parsing-test eq?
    ] unit-test

    [ T{ effect f { "a" "b" } { "d" } f } ]
    [ \ effect-parsing-test "declared-effect" word-prop ] unit-test

    [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test

    [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test

    ! Funny bug
    [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test

    [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail

    ! These should throw errors
    [ "HEX: zzz" eval ] must-fail
    [ "OCT: 999" eval ] must-fail
    [ "BIN: --0" eval ] must-fail

    ! Another funny bug
    [ t ] [
        [
            "scratchpad" in set
            { "scratchpad" "arrays" } set-use
            [
                ! This shouldn't modify in/use in the outer scope!
            ] with-file-vocabs

            use get { "scratchpad" "arrays" } set-use use get =
        ] with-scope
    ] unit-test
    DEFER: foo

    "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval

    [ ] [ "USE: parser.tests foo" eval ] unit-test

    "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval

    [ t ] [
        "USE: parser.tests \\ foo" eval
        "foo" "parser.tests" lookup eq?
    ] unit-test

    ! Test smudging

    [ 1 ] [
        "IN: parser.tests : smudge-me ;" <string-reader> "foo"
        parse-stream drop

        "foo" source-file definitions>> first assoc-size
    ] unit-test

    [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test

    [ ] [
        "IN: parser.tests : smudge-me-more ;" <string-reader> "foo"
        parse-stream drop
    ] unit-test

    [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
    [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test

    [ 3 ] [
        "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
        parse-stream drop

        "foo" source-file definitions>> first assoc-size
    ] unit-test

    [ 1 ] [
        "IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
        parse-stream drop

        "bar" source-file definitions>> first assoc-size
    ] unit-test

    [ 2 ] [
        "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
        parse-stream drop

        "foo" source-file definitions>> first assoc-size
    ] unit-test
    
    [ t ] [
        array "smudge-me" "parser.tests" lookup order memq?
    ] unit-test
    
    [ t ] [
        integer "smudge-me" "parser.tests" lookup order memq?
    ] unit-test
    
    [ f ] [
        string "smudge-me" "parser.tests" lookup order memq?
    ] unit-test

    [ ] [
        "IN: parser.tests USE: math 2 2 +" <string-reader> "a"
        parse-stream drop
    ] unit-test
    
    [ t ] [
        "a" <pathname> \ + usage member?
    ] unit-test

    [ ] [
        "IN: parser.tests USE: math 2 2 -" <string-reader> "a"
        parse-stream drop
    ] unit-test
    
    [ f ] [
        "a" <pathname> \ + usage member?
    ] unit-test
    
    [ ] [
        "a" source-files get delete-at
        2 [
            "IN: parser.tests DEFER: x : y x ; : x y ;"
            <string-reader> "a" parse-stream drop
        ] times
    ] unit-test
    
    "a" source-files get delete-at

    [
        "IN: parser.tests : x ; : y 3 throw ; this is an error"
        <string-reader> "a" parse-stream
    ] [ source-file-error? ] must-fail-with

    [ t ] [
        "y" "parser.tests" lookup >boolean
    ] unit-test

    [ f ] [
        "IN: parser.tests : x ;"
        <string-reader> "a" parse-stream drop
        
        "y" "parser.tests" lookup
    ] unit-test

    ! Test new forward definition logic
    [ ] [
        "IN: axx : axx ;"
        <string-reader> "axx" parse-stream drop
    ] unit-test

    [ ] [
        "USE: axx IN: bxx : bxx ; : cxx axx bxx ;"
        <string-reader> "bxx" parse-stream drop
    ] unit-test

    ! So we move the bxx word to axx...
    [ ] [
        "IN: axx : axx ; : bxx ;"
        <string-reader> "axx" parse-stream drop
    ] unit-test

    [ t ] [ "bxx" "axx" lookup >boolean ] unit-test

    ! And reload the file that uses it...
    [ ] [
        "USE: axx IN: bxx : cxx axx bxx ;"
        <string-reader> "bxx" parse-stream drop
    ] unit-test
    
    ! And hope not to get a forward-error!

    ! Turning a generic into a non-generic could cause all
    ! kinds of funnyness
    [ ] [
        "IN: ayy USE: kernel GENERIC: ayy M: object ayy ;"
        <string-reader> "ayy" parse-stream drop
    ] unit-test

    [ ] [
        "IN: ayy USE: kernel : ayy ;"
        <string-reader> "ayy" parse-stream drop
    ] unit-test

    [ ] [
        "IN: azz TUPLE: my-class ; GENERIC: a-generic"
        <string-reader> "azz" parse-stream drop
    ] unit-test

    [ ] [
        "USE: azz M: my-class a-generic ;"
        <string-reader> "azz-2" parse-stream drop
    ] unit-test

    [ ] [
        "IN: azz GENERIC: a-generic"
        <string-reader> "azz" parse-stream drop
    ] unit-test

    [ ] [
        "USE: azz USE: math M: integer a-generic ;"
        <string-reader> "azz-2" parse-stream drop
    ] unit-test

    [ ] [
        "IN: parser.tests : <bogus-error> ; : bogus <bogus-error> ;"
        <string-reader> "bogus-error" parse-stream drop
    ] unit-test

    [ ] [
        "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;"
        <string-reader> "bogus-error" parse-stream drop
    ] unit-test

    ! Problems with class predicates -vs- ordinary words
    [ ] [
        "IN: parser.tests TUPLE: killer ;"
        <string-reader> "removing-the-predicate" parse-stream drop
    ] unit-test

    [ ] [
        "IN: parser.tests GENERIC: killer? ( a -- b )"
        <string-reader> "removing-the-predicate" parse-stream drop
    ] unit-test
    
    [ t ] [
        "killer?" "parser.tests" lookup >boolean
    ] unit-test

    [
        "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
        <string-reader> "removing-the-predicate" parse-stream
    ] [ error>> error>> error>> redefine-error? ] must-fail-with

    [
        "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
        <string-reader> "redefining-a-class-1" parse-stream
    ] [ error>> error>> error>> redefine-error? ] must-fail-with

    [ ] [
        "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
        <string-reader> "redefining-a-class-2" parse-stream drop
    ] unit-test

    [
        "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
        <string-reader> "redefining-a-class-3" parse-stream drop
    ] [ error>> error>> error>> redefine-error? ] must-fail-with

    [ ] [
        "IN: parser.tests TUPLE: class-fwd-test ;"
        <string-reader> "redefining-a-class-3" parse-stream drop
    ] unit-test

    [
        "IN: parser.tests \\ class-fwd-test"
        <string-reader> "redefining-a-class-3" parse-stream drop
    ] [ error>> error>> error>> no-word-error? ] must-fail-with

    [ ] [
        "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
        <string-reader> "redefining-a-class-3" parse-stream drop
    ] unit-test

    [
        "IN: parser.tests \\ class-fwd-test"
        <string-reader> "redefining-a-class-3" parse-stream drop
    ] [ error>> error>> error>> no-word-error? ] must-fail-with

    [
        "IN: parser.tests : foo ; TUPLE: foo ;"
        <string-reader> "redefining-a-class-4" parse-stream drop
    ] [ error>> error>> error>> redefine-error? ] must-fail-with

    [ ] [
        "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
    ] unit-test

    [
        "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
    ] must-fail
] with-file-vocabs

[ ] [
    "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
] unit-test

[ t ] [
    "foo?" "parser.tests" lookup word eq?
] unit-test

[ ] [
    [
        "redefining-a-class-5" forget-source
        "redefining-a-class-6" forget-source
        "redefining-a-class-7" forget-source
    ] with-compilation-unit
] unit-test

2 [
    [ ] [
        "IN: parser.tests TUPLE: foo ; GENERIC: foo"
        <string-reader> "redefining-a-class-5" parse-stream drop
    ] unit-test

    [ ] [
        "IN: parser.tests M: f foo ;"
        <string-reader> "redefining-a-class-6" parse-stream drop
    ] unit-test

    [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test

    [ ] [
        "IN: parser.tests TUPLE: foo ; GENERIC: foo"
        <string-reader> "redefining-a-class-5" parse-stream drop
    ] unit-test

    [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test

    [ ] [
        "IN: parser.tests TUPLE: foo ; GENERIC: foo"
    <string-reader> "redefining-a-class-7" parse-stream drop
    ] unit-test

    [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test

    [ ] [
        "IN: parser.tests TUPLE: foo ;"
        <string-reader> "redefining-a-class-7" parse-stream drop
    ] unit-test

    [ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
] times

[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ got>> { 1 2 3 } sequence= ]
must-fail-with

2 [
    [ ] [
        "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
        <string-reader> "d-f-s-test" parse-stream drop
    ] unit-test

    [ ] [
        "IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s"
        <string-reader> "d-f-s-test" parse-stream drop
    ] unit-test

    [ ] [
        "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
        <string-reader> "d-f-s-test" parse-stream drop
    ] unit-test
] times

[ ] [
    [ "this-better-not-exist" forget-vocab ] with-compilation-unit
] unit-test

[
    "USE: this-better-not-exist" eval
] must-fail

[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with

[ 92 ] [ "CHAR: \\" eval ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test

[ ] [
    {
        "IN: parser.tests"
        "USING: math arrays ;"
        "GENERIC: change-combination"
        "M: integer change-combination 1 ;"
        "M: array change-combination 2 ;"
    } "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test

[ ] [
    {
        "IN: parser.tests"
        "USING: math arrays ;"
        "GENERIC# change-combination 1"
        "M: integer change-combination 1 ;"
        "M: array change-combination 2 ;"
    } "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test

[ 2 ] [
    "change-combination" "parser.tests" lookup
    "methods" word-prop assoc-size
] unit-test

[ ] [
    2 [
        "IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
        <string-reader> "twice-fails-test" parse-stream drop
    ] times
] unit-test

[ [ ] ] [
    "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
    <string-reader> "staging-problem-test" parse-stream
] unit-test

[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test

[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test

[ [ ] ] [
    "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
    <string-reader> "staging-problem-test" parse-stream
] unit-test

[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test

[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test

[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with

[
    "IN: parser.tests : blahy ; parsing FORGET: blahy" eval
] [
    error>> staging-violation?
] must-fail-with

! Bogus error message
DEFER: blahy

[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ]
[ error>> error>> def>> \ blahy eq? ] must-fail-with

[ ] [ f lexer set f file set "Hello world" note. ] unit-test

[ "CHAR: \\u9999999999999" eval ] must-fail

SYMBOLS: a b c ;

[ a ] [ a ] unit-test
[ b ] [ b ] unit-test
[ c ] [ c ] unit-test

DEFER: blah

[ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test
[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test

[ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test

DEFER: blah1

[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
[ error>> error>> def>> \ blah1 eq? ]
must-fail-with

IN: qualified.tests.foo
: x 1 ;
: y 5 ;
IN: qualified.tests.bar
: x 2 ;
: y 4 ;
IN: qualified.tests.baz
: x 3 ;

QUALIFIED: qualified.tests.foo
QUALIFIED: qualified.tests.bar
[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test

QUALIFIED-WITH: qualified.tests.bar p
[ 2 ] [ p:x ] unit-test

RENAME: x qualified.tests.baz => y
[ 3 ] [ y ] unit-test

FROM: qualified.tests.baz => x ;
[ 3 ] [ x ] unit-test
[ 3 ] [ y ] unit-test

EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test

[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
[ error>> no-word-error? ] must-fail-with

[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
[ error>> no-word-error? ] must-fail-with