basis/prettyprint/prettyprint-tests.factor

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