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 : method-test
 105     {
 106         "IN: prettyprint.tests"
 107         "GENERIC: method-layout"
 108         ""
 109         "USING: math prettyprint.tests ;"
 110         "M: complex method-layout"
 111         "    \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
 112         "    ;"
 113         ""
 114         "USING: math prettyprint.tests ;"
 115         "M: fixnum method-layout ;"
 116         ""
 117         "USING: math prettyprint.tests ;"
 118         "M: integer method-layout ;"
 119         ""
 120         "USING: kernel prettyprint.tests ;"
 121         "M: object method-layout ;"
 122     } ;
 123
 124 [ t ] [
 125     "method-layout" method-test check-see
 126 ] unit-test
 127
 128 : retain-stack-test
 129     {
 130         "USING: io kernel sequences words ;"
 131         "IN: prettyprint.tests"
 132         ": retain-stack-layout ( x -- )"
 133         "    dup stream-readln stream-readln"
 134         "    >r [ define ] map r>"
 135         "    define ;"
 136     } ;
 137
 138 [ t ] [
 139     "retain-stack-layout" retain-stack-test check-see
 140 ] unit-test
 141
 142 : soft-break-test
 143     {
 144         "USING: kernel math sequences strings ;"
 145         "IN: prettyprint.tests"
 146         ": soft-break-layout ( x y -- ? )"
 147         "    over string? ["
 148         "        over hashcode over hashcode number="
 149         "        [ sequence= ] [ 2drop f ] if"
 150         "    ] [ 2drop f ] if ;"
 151     } ;
 152
 153 [ t ] [
 154     "soft-break-layout" soft-break-test check-see
 155 ] unit-test
 156
 157 : another-retain-layout-test
 158     {
 159         "USING: kernel sequences ;"
 160         "IN: prettyprint.tests"
 161         ": another-retain-layout ( seq1 seq2 quot -- newseq )"
 162         "    -rot 2dup dupd min-length [ each drop roll ] map"
 163         "    >r 3drop r> ; inline"
 164     } ;
 165
 166 [ t ] [
 167     "another-retain-layout" another-retain-layout-test check-see
 168 ] unit-test
 169
 170 : another-soft-break-test
 171     {
 172         "USING: namespaces parser sequences ;"
 173         "IN: prettyprint.tests"
 174         ": another-soft-break-layout ( node -- quot )"
 175         "    parse-error-file"
 176         "    [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
 177     } ;
 178
 179 [ t ] [
 180     "another-soft-break-layout" another-soft-break-test
 181     check-see
 182 ] unit-test
 183
 184 : string-layout
 185     {
 186         "USING: io kernel parser ;"
 187         "IN: prettyprint.tests"
 188         ": string-layout-test ( error -- )"
 189         "    \"Expected \" write dup unexpected-want expected>string write"
 190         "    \" but got \" write unexpected-got expected>string print ;"
 191     } ;
 192
 193
 194 [ t ] [
 195     "string-layout-test" string-layout check-see
 196 ] unit-test
 197
 198 ! Define dummy words for the below...
 199 : <NSRect> ( a b c d -- e ) ;
 200 : <PixelFormat> ( -- fmt ) ;
 201 : send ( obj -- ) ;
 202
 203 \ send soft "break-after" set-word-prop
 204
 205 : final-soft-break-test
 206     {
 207         "USING: kernel sequences ;"
 208         "IN: prettyprint.tests"
 209         ": final-soft-break-layout ( class dim -- view )"
 210         "    >r \"alloc\" send 0 0 r>"
 211         "    first2 <NSRect>"
 212         "    <PixelFormat> \"initWithFrame:pixelFormat:\" send"
 213         "    dup 1 \"setPostsBoundsChangedNotifications:\" send"
 214         "    dup 1 \"setPostsFrameChangedNotifications:\" send ;"
 215     } ;
 216
 217 [ t ] [
 218     "final-soft-break-layout" final-soft-break-test check-see
 219 ] unit-test
 220
 221 : narrow-test
 222     {
 223         "USING: arrays combinators continuations kernel sequences ;"
 224         "IN: prettyprint.tests"
 225         ": narrow-layout ( obj -- )"
 226         "    {"
 227         "        { [ dup continuation? ] [ append ] }"
 228         "        { [ dup not ] [ drop reverse ] }"
 229         "        { [ dup pair? ] [ delete ] }"
 230         "    } cond ;"
 231     } ;
 232
 233 [ t ] [
 234     "narrow-layout" narrow-test check-see
 235 ] unit-test
 236
 237 : another-narrow-test
 238     {
 239         "IN: prettyprint.tests"
 240         ": another-narrow-layout ( -- obj )"
 241         "    H{"
 242         "        { 1 2 }"
 243         "        { 3 4 }"
 244         "        { 5 6 }"
 245         "        { 7 8 }"
 246         "        { 9 10 }"
 247         "        { 11 12 }"
 248         "        { 13 14 }"
 249         "    } ;"
 250     } ;
 251
 252 [ t ] [
 253     "another-narrow-layout" another-narrow-test check-see
 254 ] unit-test
 255
 256 : class-see-test
 257     {
 258         "IN: prettyprint.tests"
 259         "TUPLE: class-see-layout ;"
 260         ""
 261         "IN: prettyprint.tests"
 262         "GENERIC: class-see-layout ( x -- y )"
 263         ""
 264         "USING: prettyprint.tests ;"
 265         "M: class-see-layout class-see-layout ;"
 266     } ;
 267
 268 [ t ] [
 269     "class-see-layout" class-see-test check-see
 270 ] unit-test
 271
 272 [ ] [ \ effect-in synopsis drop ] unit-test
 273
 274 ! Regression
 275 [ t ] [
 276     "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
 277     dup eval
 278     "generic-decl-test" "prettyprint.tests" lookup
 279     [ see ] with-string-writer =
 280 ] unit-test
 281
 282 [ [ + ] ] [
 283     [ \ + (step-into-execute) ] (remove-breakpoints)
 284 ] unit-test
 285
 286 [ [ (step-into-execute) ] ] [
 287     [ (step-into-execute) ] (remove-breakpoints)
 288 ] unit-test
 289
 290 [ [ 2 2 + . ] ] [
 291     [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
 292 ] unit-test
 293
 294 [ [ 2 2 + . ] ] [
 295     [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
 296 ] unit-test
 297
 298 [ ] [ 1 \ + curry unparse drop ] unit-test
 299
 300 [ ] [ 1 \ + compose unparse drop ] unit-test
 301
 302 GENERIC: generic-see-test-with-f ( obj -- obj )
 303
 304 M: f generic-see-test-with-f ;
 305
 306 [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
 307     [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
 308 ] unit-test
 309
 310 [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
 311     [ \ f \ generic-see-test-with-f method see ] with-string-writer
 312 ] unit-test
 313
 314 PREDICATE: predicate-see-test < integer even? ;
 315
 316 [ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
 317     [ \ predicate-see-test see ] with-string-writer
 318 ] unit-test
 319
 320 INTERSECTION: intersection-see-test sequence number ;
 321
 322 [ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
 323     [ \ intersection-see-test see ] with-string-writer
 324 ] unit-test
 325
 326 [ ] [ \ compose see ] unit-test
 327 [ ] [ \ curry see ] unit-test
 328
 329 [ "POSTPONE: [" ] [ \ [ unparse ] unit-test