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 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 { "NAN: 123" } [ NAN: 123 unparse ] unit-test
  27 { "NAN: -123" } [ NAN: -123 unparse ] unit-test
  28
  29 { "+" } [ \ + unparse ] unit-test
  30
  31 { "\\ +" } [ [ \ + ] first unparse ] unit-test
  32
  33 { "{ }" } [ { } unparse ] unit-test
  34
  35 { "{ 1 2 3 }" } [ { 1 2 3 } unparse ] unit-test
  36
  37 { "\"hello\\\\backslash\"" }
  38 [ "hello\\backslash" unparse ]
  39 unit-test
  40
  41 ! [ "\"\\u123456\"" ]
  42 ! [ "\u123456" unparse ]
  43 ! unit-test
  44
  45 { "\"\\e\"" }
  46 [ "\e" unparse ]
  47 unit-test
  48
  49 { "\"\\x01\"" }
  50 [ 1 1string unparse ]
  51 unit-test
  52
  53 { "f" } [ f unparse ] unit-test
  54 { "t" } [ t unparse ] unit-test
  55
  56 { "SBUF\" hello world\"" } [ SBUF" hello world" unparse ] unit-test
  57
  58 { "W{ \\ + }" } [ [ W{ \ + } ] first unparse ] unit-test
  59
  60 { } [ \ fixnum see ] unit-test
  61
  62 { } [ \ integer see ] unit-test
  63
  64 { } [ \ generic see ] unit-test
  65
  66 { } [ \ duplex-stream see ] unit-test
  67
  68 { "[ \\ + ]" } [ [ \ + ] unparse ] unit-test
  69 { "[ \\ [ ]" } [ [ \ [ ] unparse ] unit-test
  70
  71 { t } [
  72     100 \ dup <array> unparse-short
  73     "{" head?
  74 ] unit-test
  75
  76 : foo ( a -- b ) dup * ; inline
  77
  78 { "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" }
  79 [ [ \ foo see ] with-string-writer ] unit-test
  80
  81 : bar ( x -- y ) 2 + ;
  82
  83 { "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" }
  84 [ [ \ bar see ] with-string-writer ] unit-test
  85
  86 : blah ( a a a a a a a a a a a a a a a a a a a a -- )
  87     drop
  88     drop
  89     drop
  90     drop
  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
 108 { "drop ;" } [
 109     [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
 110 ] unit-test
 111
 112 : check-see ( expect name -- ? )
 113     [
 114         [
 115             [ parse-fresh drop ] with-compilation-unit
 116             [
 117                 "prettyprint.tests" lookup-word see
 118             ] with-string-writer split-lines but-last
 119         ] keep =
 120     ] with-interactive-vocabs ;
 121
 122 GENERIC: method-layout ( a -- b )
 123
 124 M: complex method-layout
 125     drop
 126     "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 127     ;
 128
 129 M: fixnum method-layout ;
 130
 131 M: integer method-layout ;
 132
 133 M: object method-layout ;
 134
 135 {
 136     {
 137         "USING: kernel math prettyprint.tests ;"
 138         "M: complex method-layout"
 139         "    drop"
 140         "    \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
 141         "    ;"
 142         ""
 143         "USING: math prettyprint.tests ;"
 144         "M: fixnum method-layout ;"
 145         ""
 146         "USING: math prettyprint.tests ;"
 147         "M: integer method-layout ;"
 148         ""
 149         "USING: kernel prettyprint.tests ;"
 150         "M: object method-layout ;"
 151         ""
 152     }
 153 } [
 154     [ \ method-layout see-methods ] with-string-writer split-lines
 155 ] unit-test
 156
 157 : soft-break-test ( -- str )
 158     {
 159         "USING: kernel math sequences strings ;"
 160         "IN: prettyprint.tests"
 161         ": soft-break-layout ( x y -- ? )"
 162         "    over string? ["
 163         "        over hashcode over hashcode number="
 164         "        [ sequence= ] [ 2drop f ] if"
 165         "    ] [ 2drop f ] if ;"
 166     } ;
 167
 168 { t } [
 169     "soft-break-layout" soft-break-test check-see
 170 ] unit-test
 171
 172 DEFER: parse-error-file
 173
 174 : another-soft-break-test ( -- str )
 175     {
 176         "USING: make sequences ;"
 177         "IN: prettyprint.tests"
 178         ": another-soft-break-layout ( node -- quot )"
 179         "    parse-error-file"
 180         "    [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
 181     } ;
 182
 183 { t } [
 184     "another-soft-break-layout" another-soft-break-test
 185     check-see
 186 ] unit-test
 187
 188 : string-layout ( -- str )
 189     {
 190         "USING: accessors debugger io kernel ;"
 191         "IN: prettyprint.tests"
 192         ": string-layout-test ( error -- )"
 193         "    \"Expected \" write dup want>> expected>string write"
 194         "    \" but got \" write got>> expected>string print ;"
 195     } ;
 196
 197
 198 { t } [
 199     "string-layout-test" string-layout check-see
 200 ] unit-test
 201
 202 : narrow-test ( -- array )
 203     {
 204         "USING: arrays combinators continuations kernel sequences ;"
 205         "IN: prettyprint.tests"
 206         ": narrow-layout ( obj1 obj2 -- obj3 )"
 207         "    {"
 208         "        { [ dup continuation? ] [ append ] }"
 209         "        { [ dup not ] [ drop reverse ] }"
 210         "        { [ dup pair? ] [ [ remove! drop ] keep ] }"
 211         "    } cond ;"
 212     } ;
 213
 214 { t } [
 215     "narrow-layout" narrow-test check-see
 216 ] unit-test
 217
 218 : another-narrow-test ( -- array )
 219     {
 220         "IN: prettyprint.tests"
 221         ": another-narrow-layout ( -- obj )"
 222         "    H{"
 223         "        { 1 2 }"
 224         "        { 3 4 }"
 225         "        { 5 6 }"
 226         "        { 7 8 }"
 227         "        { 9 10 }"
 228         "        { 11 12 }"
 229         "        { 13 14 }"
 230         "    } ;"
 231     } ;
 232
 233 { t } [
 234     "another-narrow-layout" another-narrow-test check-see
 235 ] unit-test
 236
 237 IN: prettyprint.tests
 238 TUPLE: class-see-layout ;
 239
 240 IN: prettyprint.tests
 241 GENERIC: class-see-layout ( x -- y )
 242
 243 USING: prettyprint.tests ;
 244 M: class-see-layout class-see-layout ;
 245
 246 {
 247     {
 248         "IN: prettyprint.tests"
 249         "TUPLE: class-see-layout ;"
 250         ""
 251         "IN: prettyprint.tests"
 252         "GENERIC: class-see-layout ( x -- y )"
 253         ""
 254     }
 255 } [
 256     [ \ class-see-layout see ] with-string-writer split-lines
 257 ] unit-test
 258
 259 {
 260     {
 261         "USING: prettyprint.tests ;"
 262         "M: class-see-layout class-see-layout ;"
 263         ""
 264     }
 265 } [
 266     [ \ class-see-layout see-methods ] with-string-writer split-lines
 267 ] unit-test
 268
 269 { } [ \ in>> synopsis drop ] unit-test
 270
 271 ! Regression
 272 { t } [
 273     "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
 274     dup eval( -- )
 275     "generic-decl-test" "prettyprint.tests" lookup-word
 276     [ see ] with-string-writer =
 277 ] unit-test
 278
 279 { [ + ] } [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
 280
 281 { [ (step-into-execute) ] } [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
 282
 283 { [ 2 2 + . ] } [
 284     [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
 285 ] unit-test
 286
 287 { [ 2 2 + . ] } [
 288     [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
 289 ] unit-test
 290
 291 GENERIC: generic-see-test-with-f ( obj -- obj )
 292
 293 M: f generic-see-test-with-f ;
 294
 295 { "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" } [
 296     [ M\ f generic-see-test-with-f see ] with-string-writer
 297 ] unit-test
 298
 299 PREDICATE: predicate-see-test < integer even? ;
 300
 301 { "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" } [
 302     [ \ predicate-see-test see ] with-string-writer
 303 ] unit-test
 304
 305 INTERSECTION: intersection-see-test sequence number ;
 306
 307 { "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" } [
 308     [ \ intersection-see-test see ] with-string-writer
 309 ] unit-test
 310
 311 { } [ \ compose see ] unit-test
 312 { } [ \ curry see ] unit-test
 313
 314 { "POSTPONE: [" } [ \ [ unparse ] unit-test
 315
 316 TUPLE: started-out-hustlin' ;
 317
 318 GENERIC: ended-up-ballin' ( a -- b )
 319
 320 M: started-out-hustlin' ended-up-ballin' ; inline
 321
 322 { "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" } [
 323     [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
 324 ] unit-test
 325
 326 TUPLE: tuple-with-declared-slot { x integer } ;
 327
 328 {
 329     {
 330         "USING: math ;"
 331         "IN: prettyprint.tests"
 332         "TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
 333         ""
 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 } [
 348     [ \ tuple-with-read-only-slot see ] with-string-writer split-lines
 349 ] unit-test
 350
 351 TUPLE: tuple-with-initial-slot { x initial: 123 } ;
 352
 353 {
 354     {
 355         "IN: prettyprint.tests"
 356         "TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
 357         ""
 358     }
 359 } [
 360     [ \ tuple-with-initial-slot see ] with-string-writer split-lines
 361 ] unit-test
 362
 363 TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
 364
 365 {
 366     {
 367         "USING: math ;"
 368         "IN: prettyprint.tests"
 369         "TUPLE: tuple-with-initial-declared-slot"
 370         "    { x integer initial: 123 } ;"
 371         ""
 372     }
 373 } [
 374     [ \ tuple-with-initial-declared-slot see ] with-string-writer split-lines
 375 ] unit-test
 376
 377 TUPLE: final-tuple ; final
 378
 379 {
 380     {
 381         "IN: prettyprint.tests"
 382         "TUPLE: final-tuple ; final"
 383         ""
 384     }
 385 } [
 386     [ \ final-tuple see ] with-string-writer split-lines
 387 ] unit-test
 388
 389 { "H{ { 1 2 } }\n" } [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test
 390
 391 { "H{ { 1 ~array~ } }\n" } [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test
 392
 393 { "{ ~array~ }\n" } [ [ { { 1 2 } } short. ] 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