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