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 vocabs.parser ;
   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 : soft-break-test
 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
 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
 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 ! Define dummy words for the below...
 184 : <NSRect> ( a b c d -- e ) ;
 185 : <PixelFormat> ( -- fmt ) ;
 186 : send ( obj -- ) ;
 187
 188 \ send soft "break-after" set-word-prop
 189
 190 : final-soft-break-test
 191     {
 192         "USING: kernel sequences ;"
 193         "IN: prettyprint.tests"
 194         ": final-soft-break-layout ( class dim -- view )"
 195         "    [ \"alloc\" send 0 0 ] dip first2 <NSRect>"
 196         "    <PixelFormat> \"initWithFrame:pixelFormat:\" send"
 197         "    dup 1 \"setPostsBoundsChangedNotifications:\" send"
 198         "    dup 1 \"setPostsFrameChangedNotifications:\" send ;"
 199     } ;
 200
 201 [ t ] [
 202     "final-soft-break-layout" final-soft-break-test check-see
 203 ] unit-test
 204
 205 : narrow-test
 206     {
 207         "USING: arrays combinators continuations kernel sequences ;"
 208         "IN: prettyprint.tests"
 209         ": narrow-layout ( obj -- )"
 210         "    {"
 211         "        { [ dup continuation? ] [ append ] }"
 212         "        { [ dup not ] [ drop reverse ] }"
 213         "        { [ dup pair? ] [ delete ] }"
 214         "    } cond ;"
 215     } ;
 216
 217 [ t ] [
 218     "narrow-layout" narrow-test check-see
 219 ] unit-test
 220
 221 : another-narrow-test
 222     {
 223         "IN: prettyprint.tests"
 224         ": another-narrow-layout ( -- obj )"
 225         "    H{"
 226         "        { 1 2 }"
 227         "        { 3 4 }"
 228         "        { 5 6 }"
 229         "        { 7 8 }"
 230         "        { 9 10 }"
 231         "        { 11 12 }"
 232         "        { 13 14 }"
 233         "    } ;"
 234     } ;
 235
 236 [ t ] [
 237     "another-narrow-layout" another-narrow-test check-see
 238 ] unit-test
 239
 240 IN: prettyprint.tests
 241 TUPLE: class-see-layout ;
 242
 243 IN: prettyprint.tests
 244 GENERIC: class-see-layout ( x -- y )
 245
 246 USING: prettyprint.tests ;
 247 M: class-see-layout class-see-layout ;
 248
 249 [
 250     {
 251         "IN: prettyprint.tests"
 252         "TUPLE: class-see-layout ;"
 253         ""
 254         "IN: prettyprint.tests"
 255         "GENERIC: class-see-layout ( x -- y )"
 256         ""
 257     }
 258 ] [
 259     [ \ class-see-layout see ] with-string-writer "\n" split
 260 ] unit-test
 261
 262 [
 263     {
 264         "USING: prettyprint.tests ;"
 265         "M: class-see-layout class-see-layout ;"
 266         ""
 267     }
 268 ] [
 269     [ \ class-see-layout see-methods ] with-string-writer "\n" split
 270 ] unit-test
 271
 272 [ ] [ \ 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 GENERIC: generic-see-test-with-f ( obj -- obj )
 299
 300 M: f generic-see-test-with-f ;
 301
 302 [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
 303     [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
 304 ] unit-test
 305
 306 [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
 307     [ \ f \ generic-see-test-with-f method see ] with-string-writer
 308 ] unit-test
 309
 310 PREDICATE: predicate-see-test < integer even? ;
 311
 312 [ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
 313     [ \ predicate-see-test see ] with-string-writer
 314 ] unit-test
 315
 316 INTERSECTION: intersection-see-test sequence number ;
 317
 318 [ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
 319     [ \ intersection-see-test see ] with-string-writer
 320 ] unit-test
 321
 322 [ ] [ \ compose see ] unit-test
 323 [ ] [ \ curry see ] unit-test
 324
 325 [ "POSTPONE: [" ] [ \ [ unparse ] unit-test
 326
 327 TUPLE: started-out-hustlin' ;
 328
 329 GENERIC: ended-up-ballin'
 330
 331 M: started-out-hustlin' ended-up-ballin' ; inline
 332
 333 [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
 334     [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
 335 ] unit-test