basis/prettyprint/prettyprint-tests.factor

   1 USING: accessors arrays classes.intersection classes.maybe
   2 classes.union compiler.units continuations definitions effects
   3 eval generic generic.standard hashtables io io.streams.duplex
   4 io.streams.string kernel listener make math namespaces parser
   5 prettyprint prettyprint.backend prettyprint.config prettyprint.private
   6 prettyprint.sections see sequences splitting
   7 strings system tools.continuations tools.continuations.private
   8 tools.test vectors vocabs.parser words ;
   9 IN: prettyprint.tests
  10
  11 { "4" } [ 4 unparse ] unit-test
  12 { "4096" } [ 4096 unparse ] unit-test
  13 { "0b1000000000000" } [ 2 number-base [ 4096 unparse ] with-variable ] unit-test
  14 { "0o10000" } [ 8 number-base [ 4096 unparse ] with-variable ] unit-test
  15 { "0x1000" } [ 16 number-base [ 4096 unparse ] with-variable ] unit-test
  16 { "1.0" } [ 1.0 unparse ] unit-test
  17 { "8.0" } [ 8.0 unparse ] unit-test
  18 { "0b1.001p4" } [ 2 number-base [ 18.0 unparse ] with-variable ] unit-test
  19 { "0o1.1p4" } [ 8 number-base [ 18.0 unparse ] with-variable ] unit-test
  20 { "0x1.2p4" } [ 16 number-base [ 18.0 unparse ] with-variable ] unit-test
  21 { "1267650600228229401496703205376" } [ 1 100 shift unparse ] unit-test
  22 { "1/0." } [ 1/0. unparse ] unit-test
  23 { "-1/0." } [ -1/0. unparse ] unit-test
  24 { "0/0." } [ 0/0. unparse ] unit-test
  25 { "-0/0." } [ -0/0. unparse ] unit-test
  26
  27 ! XXX: disabling on linux/x86.32
  28 os linux? cpu x86.32? and [
  29     { "NAN: 123" } [ NAN: 123 unparse ] unit-test
  30 ] unless
  31 { "NAN: -123" } [ NAN: -123 unparse ] unit-test
  32
  33 { "+" } [ \ + unparse ] unit-test
  34
  35 { "\\ +" } [ [ \ + ] first unparse ] unit-test
  36
  37 { "{ }" } [ { } unparse ] unit-test
  38
  39 { "{ 1 2 3 }" } [ { 1 2 3 } unparse ] unit-test
  40
  41 { "\"hello\\\\backslash\"" }
  42 [ "hello\\backslash" unparse ]
  43 unit-test
  44
  45 ! [ "\"\\u123456\"" ]
  46 ! [ "\u123456" unparse ]
  47 ! unit-test
  48
  49 { "\"\\e\"" }
  50 [ "\e" unparse ]
  51 unit-test
  52
  53 { "\"\\x01\"" }
  54 [ 1 1string unparse ]
  55 unit-test
  56
  57 { "f" } [ f unparse ] unit-test
  58 { "t" } [ t unparse ] unit-test
  59
  60 { "SBUF\" hello world\"" } [ SBUF" hello world" unparse ] unit-test
  61
  62 { "W{ \\ + }" } [ [ W{ \ + } ] first unparse ] unit-test
  63
  64 { } [ \ fixnum see ] unit-test
  65
  66 { } [ \ integer see ] unit-test
  67
  68 { } [ \ generic see ] unit-test
  69
  70 { } [ \ duplex-stream see ] unit-test
  71
  72 { "[ \\ + ]" } [ [ \ + ] unparse ] unit-test
  73 { "[ \\ [ ]" } [ [ \ [ ] unparse ] unit-test
  74
  75 { t } [
  76     100 \ dup <array> unparse-short
  77     "{" head?
  78 ] unit-test
  79
  80 : foo ( a -- b ) dup * ; inline
  81
  82 { "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" }
  83 [ [ \ foo see ] with-string-writer ] unit-test
  84
  85 : bar ( x -- y ) 2 + ;
  86
  87 { "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" }
  88 [ [ \ bar see ] with-string-writer ] unit-test
  89
  90 : blah ( a a a a a a a a a a a a a a a a a a a a -- )
  91     drop
  92     drop
  93     drop
  94     drop
  95     drop
  96     drop
  97     drop
  98     drop
  99     drop
 100     drop
 101     drop
 102     drop
 103     drop
 104     drop
 105     drop
 106     drop
 107     drop
 108     drop
 109     drop
 110     drop ;
 111
 112 { "drop ;" } [
 113     [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
 114 ] unit-test
 115
 116 : check-see ( expect name -- ? )
 117     [
 118         [
 119             [ parse-fresh drop ] with-compilation-unit
 120             [
 121                 "prettyprint.tests" lookup-word see
 122             ] with-string-writer split-lines
 123         ] keep =
 124     ] with-interactive-vocabs ;
 125
 126 GENERIC: method-layout ( a -- b )
 127
 128 M: complex method-layout
 129     drop
 130     "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 131     ;
 132
 133 M: fixnum method-layout ;
 134
 135 M: integer method-layout ;
 136
 137 M: object method-layout ;
 138
 139 {
 140     {
 141         "USING: kernel math prettyprint.tests ;"
 142         "M: complex method-layout"
 143         "    drop"
 144         "    \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
 145         "    ;"
 146         ""
 147         "USING: math prettyprint.tests ;"
 148         "M: fixnum method-layout ;"
 149         ""
 150         "USING: math prettyprint.tests ;"
 151         "M: integer method-layout ;"
 152         ""
 153         "USING: kernel prettyprint.tests ;"
 154         "M: object method-layout ;"
 155     }
 156 } [
 157     [ \ method-layout see-methods ] with-string-writer split-lines
 158 ] unit-test
 159
 160 : soft-break-test ( -- str )
 161     {
 162         "USING: kernel math sequences strings ;"
 163         "IN: prettyprint.tests"
 164         ": soft-break-layout ( x y -- ? )"
 165         "    over string? ["
 166         "        over hashcode over hashcode number="
 167         "        [ sequence= ] [ 2drop f ] if"
 168         "    ] [ 2drop f ] if ;"
 169     } ;
 170
 171 { t } [
 172     "soft-break-layout" soft-break-test check-see
 173 ] unit-test
 174
 175 DEFER: parse-error-file
 176
 177 : another-soft-break-test ( -- str )
 178     {
 179         "USING: make sequences ;"
 180         "IN: prettyprint.tests"
 181         ": another-soft-break-layout ( node -- quot )"
 182         "    parse-error-file"
 183         "    [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
 184     } ;
 185
 186 { t } [
 187     "another-soft-break-layout" another-soft-break-test
 188     check-see
 189 ] unit-test
 190
 191 : string-layout ( -- str )
 192     {
 193         "USING: accessors debugger io kernel ;"
 194         "IN: prettyprint.tests"
 195         ": string-layout-test ( error -- )"
 196         "    \"Expected \" write dup want>> expected>string write"
 197         "    \" but got \" write got>> expected>string print ;"
 198     } ;
 199
 200
 201 { t } [
 202     "string-layout-test" string-layout check-see
 203 ] unit-test
 204
 205 : narrow-test ( -- array )
 206     {
 207         "USING: arrays combinators continuations kernel sequences ;"
 208         "IN: prettyprint.tests"
 209         ": narrow-layout ( obj1 obj2 -- obj3 )"
 210         "    {"
 211         "        { [ dup continuation? ] [ append ] }"
 212         "        { [ dup not ] [ drop reverse ] }"
 213         "        { [ dup pair? ] [ [ remove! drop ] keep ] }"
 214         "    } cond ;"
 215     } ;
 216
 217 { t } [
 218     "narrow-layout" narrow-test check-see
 219 ] unit-test
 220
 221 : another-narrow-test ( -- array )
 222     {
 223         "IN: prettyprint.tests"
 224         ": another-narrow-layout ( -- obj )"
 225         "    H{"
 226         "        { 1 2 }"
 227         "        { 3 4 }"
 228         "        { 5 6 }"
 229         "        { 7 8 }"
 230         "        { 9 10 }"
 231         "        { 11 12 }"
 232         "        { 13 14 }"
 233         "    } ;"
 234     } ;
 235
 236 { t } [
 237     "another-narrow-layout" another-narrow-test check-see
 238 ] unit-test
 239
 240 IN: prettyprint.tests
 241 TUPLE: class-see-layout ;
 242
 243 IN: prettyprint.tests
 244 GENERIC: class-see-layout ( x -- y )
 245
 246 USING: prettyprint.tests ;
 247 M: class-see-layout class-see-layout ;
 248
 249 {
 250     {
 251         "IN: prettyprint.tests"
 252         "TUPLE: class-see-layout ;"
 253         ""
 254         "IN: prettyprint.tests"
 255         "GENERIC: class-see-layout ( x -- y )"
 256     }
 257 } [
 258     [ \ class-see-layout see ] with-string-writer split-lines
 259 ] unit-test
 260
 261 {
 262     {
 263         "USING: prettyprint.tests ;"
 264         "M: class-see-layout class-see-layout ;"
 265     }
 266 } [
 267     [ \ class-see-layout see-methods ] with-string-writer split-lines
 268 ] unit-test
 269
 270 { } [ \ in>> synopsis drop ] unit-test
 271
 272 ! Regression
 273 { t } [
 274     "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
 275     dup eval( -- )
 276     "generic-decl-test" "prettyprint.tests" lookup-word
 277     [ see ] with-string-writer =
 278 ] unit-test
 279
 280 { [ + ] } [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
 281
 282 { [ (step-into-execute) ] } [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
 283
 284 { [ 2 2 + . ] } [
 285     [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
 286 ] unit-test
 287
 288 { [ 2 2 + . ] } [
 289     [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
 290 ] unit-test
 291
 292 GENERIC: generic-see-test-with-f ( obj -- obj )
 293
 294 M: f generic-see-test-with-f ;
 295
 296 { "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" } [
 297     [ M\ f generic-see-test-with-f see ] with-string-writer
 298 ] unit-test
 299
 300 PREDICATE: predicate-see-test < integer even? ;
 301
 302 { "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" } [
 303     [ \ predicate-see-test see ] with-string-writer
 304 ] unit-test
 305
 306 INTERSECTION: intersection-see-test sequence number ;
 307
 308 { "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" } [
 309     [ \ intersection-see-test see ] with-string-writer
 310 ] unit-test
 311
 312 { } [ \ compose see ] unit-test
 313 { } [ \ curry see ] unit-test
 314
 315 { "POSTPONE: [" } [ \ [ unparse ] unit-test
 316
 317 TUPLE: started-out-hustlin' ;
 318
 319 GENERIC: ended-up-ballin' ( a -- b )
 320
 321 M: started-out-hustlin' ended-up-ballin' ; inline
 322
 323 { "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" } [
 324     [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
 325 ] unit-test
 326
 327 TUPLE: tuple-with-declared-slot { x integer } ;
 328
 329 {
 330     {
 331         "USING: math ;"
 332         "IN: prettyprint.tests"
 333         "TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
 334     }
 335 } [
 336     [ \ tuple-with-declared-slot see ] with-string-writer split-lines
 337 ] unit-test
 338
 339 TUPLE: tuple-with-read-only-slot { x read-only } ;
 340
 341 {
 342     {
 343         "IN: prettyprint.tests"
 344         "TUPLE: tuple-with-read-only-slot { x read-only } ;"
 345     }
 346 } [
 347     [ \ tuple-with-read-only-slot see ] with-string-writer split-lines
 348 ] unit-test
 349
 350 TUPLE: tuple-with-initial-slot { x initial: 123 } ;
 351
 352 {
 353     {
 354         "IN: prettyprint.tests"
 355         "TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
 356     }
 357 } [
 358     [ \ tuple-with-initial-slot see ] with-string-writer split-lines
 359 ] unit-test
 360
 361 TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
 362
 363 {
 364     {
 365         "USING: math ;"
 366         "IN: prettyprint.tests"
 367         "TUPLE: tuple-with-initial-declared-slot"
 368         "    { x integer initial: 123 } ;"
 369     }
 370 } [
 371     [ \ tuple-with-initial-declared-slot see ] with-string-writer split-lines
 372 ] unit-test
 373
 374 TUPLE: final-tuple ; final
 375
 376 {
 377     {
 378         "IN: prettyprint.tests"
 379         "TUPLE: final-tuple ; final"
 380     }
 381 } [
 382     [ \ final-tuple see ] with-string-writer split-lines
 383 ] unit-test
 384
 385 { "H{ { 1 2 } }\n" } [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test
 386
 387 { "H{ { 1 ~array~ } }\n" } [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test
 388
 389 { "{ ~array~ }\n" } [ [ { { 1 2 } } short. ] with-string-writer ] unit-test
 390
 391 { "{ { 1 2 } }\n" } [ [ [ { { 1 2 } } short. ] without-limits ] with-string-writer ] unit-test
 392
 393 { "{ ~array~ }\n" } [ [ [ { { 1 2 } } . ] with-short-limits ] with-string-writer ] unit-test
 394
 395 { "H{ { 1 { 2 3 } } }\n" } [
 396     f nesting-limit [
 397         [ H{ { 1 { 2 3 } } } . ] with-string-writer
 398     ] with-variable
 399 ] unit-test
 400
 401 { "maybe{ integer }\n" } [ [  maybe{ integer } . ] with-string-writer ] unit-test
 402 TUPLE: bob a b ;
 403 { "maybe{ bob }\n" } [ [ maybe{ bob } . ] with-string-writer ] unit-test
 404 { "maybe{ word }\n" } [ [ maybe{ word } . ] with-string-writer ] unit-test
 405
 406 TUPLE: har a ;
 407 GENERIC: harhar ( obj -- obj )
 408 M: maybe{ har } harhar ;
 409 M: integer harhar M\ integer harhar drop ;
 410 {
 411 "USING: prettyprint.tests ;
 412 M: maybe{ har } harhar ;
 413
 414 USING: kernel math prettyprint.tests ;
 415 M: integer harhar M\\ integer harhar drop ;\n"
 416 } [
 417     [ \ harhar see-methods ] with-string-writer
 418 ] unit-test
 419
 420 TUPLE: mo { a union{ float integer } } ;
 421 TUPLE: fo { a intersection{ fixnum integer } } ;
 422
 423 {
 424 "USING: math ;
 425 IN: prettyprint.tests
 426 TUPLE: mo { a union{ integer float } initial: 0 } ;
 427 "
 428 } [
 429     [ \ mo see ] with-string-writer
 430 ] unit-test
 431
 432 {
 433 "USING: math ;
 434 IN: prettyprint.tests
 435 TUPLE: fo { a intersection{ integer fixnum } initial: 0 } ;
 436 "
 437 } [
 438     [ \ fo see ] with-string-writer
 439 ] unit-test
 440
 441 {
 442 "union{ intersection{ string hashtable } union{ integer float } }\n"
 443 } [ [ union{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test
 444
 445 {
 446 "intersection{
 447     intersection{ string hashtable }
 448     union{ integer float }
 449 }
 450 "
 451 } [ [ intersection{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test
 452
 453 {
 454 "maybe{ union{ integer float } }\n"
 455 } [
 456     [ maybe{ union{ float integer } } . ] with-string-writer
 457 ] unit-test
 458
 459 {
 460 "maybe{ maybe{ integer } }\n"
 461 } [
 462     [ maybe{ maybe{ integer } } . ] with-string-writer
 463 ] unit-test
 464
 465 { "{ 0 1 2 3 4 }" } [
 466     [ 5 length-limit [ 5 <iota> >array pprint ] with-variable ]
 467     with-string-writer
 468 ] unit-test
 469
 470 { "{ 0 1 2 3 ~2 more~ }" } [
 471     [ 5 length-limit [ 6 <iota> >array pprint ] with-variable ]
 472     with-string-writer
 473 ] unit-test
 474
 475 : margin-test ( number-of-'a's -- str )
 476     [
 477         [ CHAR: a <string> text "b" text ] with-pprint
 478     ] with-string-writer ;
 479
 480 {
 481 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b"
 482 } [ margin get 3 - margin-test ] unit-test
 483
 484 {
 485 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b"
 486 } [ margin get 2 - margin-test ] unit-test
 487
 488 {
 489 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 490 b"
 491 } [ margin get 1 - margin-test ] unit-test