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