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
 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     [ \ method-layout see-methods ] with-string-writer split-lines
 154 ] unit-test
 155
 156 : soft-break-test ( -- str )
 157     {
 158         "USING: kernel math sequences strings ;"
 159         "IN: prettyprint.tests"
 160         ": soft-break-layout ( x y -- ? )"
 161         "    over string? ["
 162         "        over hashcode over hashcode number="
 163         "        [ sequence= ] [ 2drop f ] if"
 164         "    ] [ 2drop f ] if ;"
 165     } ;
 166
 167 { t } [
 168     "soft-break-layout" soft-break-test check-see
 169 ] unit-test
 170
 171 DEFER: parse-error-file
 172
 173 : another-soft-break-test ( -- str )
 174     {
 175         "USING: make sequences ;"
 176         "IN: prettyprint.tests"
 177         ": another-soft-break-layout ( node -- quot )"
 178         "    parse-error-file"
 179         "    [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
 180     } ;
 181
 182 { t } [
 183     "another-soft-break-layout" another-soft-break-test
 184     check-see
 185 ] unit-test
 186
 187 : string-layout ( -- str )
 188     {
 189         "USING: accessors debugger io kernel ;"
 190         "IN: prettyprint.tests"
 191         ": string-layout-test ( error -- )"
 192         "    \"Expected \" write dup want>> expected>string write"
 193         "    \" but got \" write got>> expected>string print ;"
 194     } ;
 195
 196
 197 { t } [
 198     "string-layout-test" string-layout check-see
 199 ] unit-test
 200
 201 : narrow-test ( -- array )
 202     {
 203         "USING: arrays combinators continuations kernel sequences ;"
 204         "IN: prettyprint.tests"
 205         ": narrow-layout ( obj1 obj2 -- obj3 )"
 206         "    {"
 207         "        { [ dup continuation? ] [ append ] }"
 208         "        { [ dup not ] [ drop reverse ] }"
 209         "        { [ dup pair? ] [ [ remove! drop ] keep ] }"
 210         "    } cond ;"
 211     } ;
 212
 213 { t } [
 214     "narrow-layout" narrow-test check-see
 215 ] unit-test
 216
 217 : another-narrow-test ( -- array )
 218     {
 219         "IN: prettyprint.tests"
 220         ": another-narrow-layout ( -- obj )"
 221         "    H{"
 222         "        { 1 2 }"
 223         "        { 3 4 }"
 224         "        { 5 6 }"
 225         "        { 7 8 }"
 226         "        { 9 10 }"
 227         "        { 11 12 }"
 228         "        { 13 14 }"
 229         "    } ;"
 230     } ;
 231
 232 { t } [
 233     "another-narrow-layout" another-narrow-test check-see
 234 ] unit-test
 235
 236 IN: prettyprint.tests
 237 TUPLE: class-see-layout ;
 238
 239 IN: prettyprint.tests
 240 GENERIC: class-see-layout ( x -- y )
 241
 242 USING: prettyprint.tests ;
 243 M: class-see-layout class-see-layout ;
 244
 245 {
 246     {
 247         "IN: prettyprint.tests"
 248         "TUPLE: class-see-layout ;"
 249         ""
 250         "IN: prettyprint.tests"
 251         "GENERIC: class-see-layout ( x -- y )"
 252     }
 253 } [
 254     [ \ class-see-layout see ] with-string-writer split-lines
 255 ] unit-test
 256
 257 {
 258     {
 259         "USING: prettyprint.tests ;"
 260         "M: class-see-layout class-see-layout ;"
 261     }
 262 } [
 263     [ \ class-see-layout see-methods ] with-string-writer split-lines
 264 ] unit-test
 265
 266 { } [ \ in>> synopsis drop ] unit-test
 267
 268 ! Regression
 269 { t } [
 270     "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
 271     dup eval( -- )
 272     "generic-decl-test" "prettyprint.tests" lookup-word
 273     [ see ] with-string-writer =
 274 ] unit-test
 275
 276 { [ + ] } [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
 277
 278 { [ (step-into-execute) ] } [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
 279
 280 { [ 2 2 + . ] } [
 281     [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
 282 ] unit-test
 283
 284 { [ 2 2 + . ] } [
 285     [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
 286 ] unit-test
 287
 288 GENERIC: generic-see-test-with-f ( obj -- obj )
 289
 290 M: f generic-see-test-with-f ;
 291
 292 { "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" } [
 293     [ M\ f generic-see-test-with-f see ] with-string-writer
 294 ] unit-test
 295
 296 PREDICATE: predicate-see-test < integer even? ;
 297
 298 { "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" } [
 299     [ \ predicate-see-test see ] with-string-writer
 300 ] unit-test
 301
 302 INTERSECTION: intersection-see-test sequence number ;
 303
 304 { "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" } [
 305     [ \ intersection-see-test see ] with-string-writer
 306 ] unit-test
 307
 308 { } [ \ compose see ] unit-test
 309 { } [ \ curry see ] unit-test
 310
 311 { "POSTPONE: [" } [ \ [ unparse ] unit-test
 312
 313 TUPLE: started-out-hustlin' ;
 314
 315 GENERIC: ended-up-ballin' ( a -- b )
 316
 317 M: started-out-hustlin' ended-up-ballin' ; inline
 318
 319 { "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" } [
 320     [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
 321 ] unit-test
 322
 323 TUPLE: tuple-with-declared-slot { x integer } ;
 324
 325 {
 326     {
 327         "USING: math ;"
 328         "IN: prettyprint.tests"
 329         "TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
 330     }
 331 } [
 332     [ \ tuple-with-declared-slot see ] with-string-writer split-lines
 333 ] unit-test
 334
 335 TUPLE: tuple-with-read-only-slot { x read-only } ;
 336
 337 {
 338     {
 339         "IN: prettyprint.tests"
 340         "TUPLE: tuple-with-read-only-slot { x read-only } ;"
 341     }
 342 } [
 343     [ \ tuple-with-read-only-slot see ] with-string-writer split-lines
 344 ] unit-test
 345
 346 TUPLE: tuple-with-initial-slot { x initial: 123 } ;
 347
 348 {
 349     {
 350         "IN: prettyprint.tests"
 351         "TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
 352     }
 353 } [
 354     [ \ tuple-with-initial-slot see ] with-string-writer split-lines
 355 ] unit-test
 356
 357 TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
 358
 359 {
 360     {
 361         "USING: math ;"
 362         "IN: prettyprint.tests"
 363         "TUPLE: tuple-with-initial-declared-slot"
 364         "    { x integer initial: 123 } ;"
 365     }
 366 } [
 367     [ \ tuple-with-initial-declared-slot see ] with-string-writer split-lines
 368 ] unit-test
 369
 370 TUPLE: final-tuple ; final
 371
 372 {
 373     {
 374         "IN: prettyprint.tests"
 375         "TUPLE: final-tuple ; final"
 376     }
 377 } [
 378     [ \ final-tuple see ] with-string-writer split-lines
 379 ] unit-test
 380
 381 { "H{ { 1 2 } }\n" } [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test
 382
 383 { "H{ { 1 ~array~ } }\n" } [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test
 384
 385 { "{ ~array~ }\n" } [ [ { { 1 2 } } short. ] with-string-writer ] unit-test
 386
 387 { "H{ { 1 { 2 3 } } }\n" } [
 388     f nesting-limit [
 389         [ H{ { 1 { 2 3 } } } . ] with-string-writer
 390     ] with-variable
 391 ] unit-test
 392
 393 { "maybe{ integer }\n" } [ [  maybe{ integer } . ] with-string-writer ] unit-test
 394 TUPLE: bob a b ;
 395 { "maybe{ bob }\n" } [ [ maybe{ bob } . ] with-string-writer ] unit-test
 396 { "maybe{ word }\n" } [ [ maybe{ word } . ] with-string-writer ] unit-test
 397
 398 TUPLE: har a ;
 399 GENERIC: harhar ( obj -- obj )
 400 M: maybe{ har } harhar ;
 401 M: integer harhar M\ integer harhar drop ;
 402 {
 403 "USING: prettyprint.tests ;
 404 M: maybe{ har } harhar ;
 405
 406 USING: kernel math prettyprint.tests ;
 407 M: integer harhar M\\ integer harhar drop ;\n"
 408 } [
 409     [ \ harhar see-methods ] with-string-writer
 410 ] unit-test
 411
 412 TUPLE: mo { a union{ float integer } } ;
 413 TUPLE: fo { a intersection{ fixnum integer } } ;
 414
 415 {
 416 "USING: math ;
 417 IN: prettyprint.tests
 418 TUPLE: mo { a union{ integer float } initial: 0 } ;
 419 "
 420 } [
 421     [ \ mo see ] with-string-writer
 422 ] unit-test
 423
 424 {
 425 "USING: math ;
 426 IN: prettyprint.tests
 427 TUPLE: fo { a intersection{ integer fixnum } initial: 0 } ;
 428 "
 429 } [
 430     [ \ fo see ] with-string-writer
 431 ] unit-test
 432
 433 {
 434 "union{ intersection{ string hashtable } union{ integer float } }\n"
 435 } [ [ union{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test
 436
 437 {
 438 "intersection{
 439     intersection{ string hashtable }
 440     union{ integer float }
 441 }
 442 "
 443 } [ [ intersection{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test
 444
 445 {
 446 "maybe{ union{ integer float } }\n"
 447 } [
 448     [ maybe{ union{ float integer } } . ] with-string-writer
 449 ] unit-test
 450
 451 {
 452 "maybe{ maybe{ integer } }\n"
 453 } [
 454     [ maybe{ maybe{ integer } } . ] with-string-writer
 455 ] unit-test
 456
 457 { "{ 0 1 2 3 4 }" } [
 458     [ 5 length-limit [ 5 <iota> >array pprint ] with-variable ]
 459     with-string-writer
 460 ] unit-test
 461
 462 { "{ 0 1 2 3 ~2 more~ }" } [
 463     [ 5 length-limit [ 6 <iota> >array pprint ] with-variable ]
 464     with-string-writer
 465 ] unit-test
 466
 467 : margin-test ( number-of-'a's -- str )
 468     [
 469         [ CHAR: a <string> text "b" text ] with-pprint
 470     ] with-string-writer ;
 471
 472 {
 473 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b"
 474 } [ margin get 3 - margin-test ] unit-test
 475
 476 {
 477 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b"
 478 } [ margin get 2 - margin-test ] unit-test
 479
 480 {
 481 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 482 b"
 483 } [ margin get 1 - margin-test ] unit-test