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