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