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