-USING: arrays definitions io.streams.string io.streams.duplex
-kernel math namespaces parser prettyprint prettyprint.config
-prettyprint.sections sequences tools.test vectors words
-effects splitting generic.standard prettyprint.private
-continuations generic compiler.units tools.walker eval
-accessors make vocabs.parser see ;
+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
drop ;
[ "drop ;" ] [
- \ blah f "inferred-effect" set-word-prop
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test
-: check-see ( expect name -- )
+: check-see ( expect name -- ? )
[
- use [ clone ] change
-
[
[ parse-fresh drop ] with-compilation-unit
[
- "prettyprint.tests" lookup see
+ "prettyprint.tests" lookup-word see
] with-string-writer "\n" split but-last
] keep =
- ] with-scope ;
+ ] with-interactive-vocabs ;
GENERIC: method-layout ( a -- b )
M: complex method-layout
+ drop
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
;
[
{
- "USING: math prettyprint.tests ;"
+ "USING: kernel math prettyprint.tests ;"
"M: complex method-layout"
+ " drop"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;"
""
"string-layout-test" string-layout check-see
] unit-test
-: narrow-test ( -- str )
+: narrow-test ( -- array )
{
"USING: arrays combinators continuations kernel sequences ;"
"IN: prettyprint.tests"
- ": narrow-layout ( obj -- )"
+ ": narrow-layout ( obj1 obj2 -- obj3 )"
" {"
" { [ dup continuation? ] [ append ] }"
" { [ dup not ] [ drop reverse ] }"
- " { [ dup pair? ] [ delete ] }"
+ " { [ dup pair? ] [ [ remove! drop ] keep ] }"
" } cond ;"
} ;
"narrow-layout" narrow-test check-see
] unit-test
-: another-narrow-test ( -- str )
+: another-narrow-test ( -- array )
{
"IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
! Regression
[ t ] [
"IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
- dup eval
- "generic-decl-test" "prettyprint.tests" lookup
+ 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
+[ [ + ] ] [ [ \ + (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
[ "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{ float integer } initial: 0 } ;
+"""
+] [
+ [ \ mo see ] with-string-writer
+] unit-test
+
+[
+"""USING: math ;
+IN: prettyprint.tests
+TUPLE: fo { a intersection{ fixnum integer } initial: 0 } ;
+"""
+] [
+ [ \ fo see ] with-string-writer
+] unit-test
+
+[
+"""union{
+ union{ float integer }
+ intersection{ string hashtable }
+}
+"""
+] [ [ union{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test
+
+[
+"""intersection{
+ union{ float integer }
+ intersection{ string hashtable }
+}
+"""
+] [ [ intersection{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test
+
+[
+"""maybe: union{ float integer }\n"""
+] [
+ [ maybe: union{ float integer } . ] with-string-writer
+] unit-test
+
+[
+"""maybe: maybe: integer\n"""
+] [
+ [ maybe: maybe: integer . ] with-string-writer
+] unit-test
projects / factor.git / blobdiff