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