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.continuations
   6 tools.continuations.private eval accessors make vocabs.parser see ;
   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 ( a a a a a a a a a a a a a a a a a a a a -- )
  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 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 ( a -- b )
 105
 106 M: complex method-layout
 107     drop
 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: kernel math prettyprint.tests ;"
 120         "M: complex method-layout"
 121         "    drop"
 122         "    \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
 123         "    ;"
 124         ""
 125         "USING: math prettyprint.tests ;"
 126         "M: fixnum method-layout ;"
 127         ""
 128         "USING: math prettyprint.tests ;"
 129         "M: integer method-layout ;"
 130         ""
 131         "USING: kernel prettyprint.tests ;"
 132         "M: object method-layout ;"
 133         ""
 134     }
 135 ] [
 136     [ \ method-layout see-methods ] with-string-writer "\n" split
 137 ] unit-test
 138
 139 : soft-break-test ( -- str )
 140     {
 141         "USING: kernel math sequences strings ;"
 142         "IN: prettyprint.tests"
 143         ": soft-break-layout ( x y -- ? )"
 144         "    over string? ["
 145         "        over hashcode over hashcode number="
 146         "        [ sequence= ] [ 2drop f ] if"
 147         "    ] [ 2drop f ] if ;"
 148     } ;
 149
 150 [ t ] [
 151     "soft-break-layout" soft-break-test check-see
 152 ] unit-test
 153
 154 DEFER: parse-error-file
 155
 156 : another-soft-break-test ( -- str )
 157     {
 158         "USING: make sequences ;"
 159         "IN: prettyprint.tests"
 160         ": another-soft-break-layout ( node -- quot )"
 161         "    parse-error-file"
 162         "    [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
 163     } ;
 164
 165 [ t ] [
 166     "another-soft-break-layout" another-soft-break-test
 167     check-see
 168 ] unit-test
 169
 170 : string-layout ( -- str )
 171     {
 172         "USING: accessors debugger io kernel ;"
 173         "IN: prettyprint.tests"
 174         ": string-layout-test ( error -- )"
 175         "    \"Expected \" write dup want>> expected>string write"
 176         "    \" but got \" write got>> expected>string print ;"
 177     } ;
 178
 179
 180 [ t ] [
 181     "string-layout-test" string-layout check-see
 182 ] unit-test
 183
 184 : narrow-test ( -- array )
 185     {
 186         "USING: arrays combinators continuations kernel sequences ;"
 187         "IN: prettyprint.tests"
 188         ": narrow-layout ( obj1 obj2 -- obj3 )"
 189         "    {"
 190         "        { [ dup continuation? ] [ append ] }"
 191         "        { [ dup not ] [ drop reverse ] }"
 192         "        { [ dup pair? ] [ [ delete ] keep ] }"
 193         "    } cond ;"
 194     } ;
 195
 196 [ t ] [
 197     "narrow-layout" narrow-test check-see
 198 ] unit-test
 199
 200 : another-narrow-test ( -- array )
 201     {
 202         "IN: prettyprint.tests"
 203         ": another-narrow-layout ( -- obj )"
 204         "    H{"
 205         "        { 1 2 }"
 206         "        { 3 4 }"
 207         "        { 5 6 }"
 208         "        { 7 8 }"
 209         "        { 9 10 }"
 210         "        { 11 12 }"
 211         "        { 13 14 }"
 212         "    } ;"
 213     } ;
 214
 215 [ t ] [
 216     "another-narrow-layout" another-narrow-test check-see
 217 ] unit-test
 218
 219 IN: prettyprint.tests
 220 TUPLE: class-see-layout ;
 221
 222 IN: prettyprint.tests
 223 GENERIC: class-see-layout ( x -- y )
 224
 225 USING: prettyprint.tests ;
 226 M: class-see-layout class-see-layout ;
 227
 228 [
 229     {
 230         "IN: prettyprint.tests"
 231         "TUPLE: class-see-layout ;"
 232         ""
 233         "IN: prettyprint.tests"
 234         "GENERIC: class-see-layout ( x -- y )"
 235         ""
 236     }
 237 ] [
 238     [ \ class-see-layout see ] with-string-writer "\n" split
 239 ] unit-test
 240
 241 [
 242     {
 243         "USING: prettyprint.tests ;"
 244         "M: class-see-layout class-see-layout ;"
 245         ""
 246     }
 247 ] [
 248     [ \ class-see-layout see-methods ] with-string-writer "\n" split
 249 ] unit-test
 250
 251 [ ] [ \ in>> synopsis drop ] unit-test
 252
 253 ! Regression
 254 [ t ] [
 255     "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
 256     dup eval( -- )
 257     "generic-decl-test" "prettyprint.tests" lookup
 258     [ see ] with-string-writer =
 259 ] unit-test
 260
 261 [ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
 262
 263 [ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
 264
 265 [ [ 2 2 + . ] ] [
 266     [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
 267 ] unit-test
 268
 269 [ [ 2 2 + . ] ] [
 270     [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
 271 ] unit-test
 272
 273 GENERIC: generic-see-test-with-f ( obj -- obj )
 274
 275 M: f generic-see-test-with-f ;
 276
 277 [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
 278     [ M\ f generic-see-test-with-f see ] with-string-writer
 279 ] unit-test
 280
 281 PREDICATE: predicate-see-test < integer even? ;
 282
 283 [ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
 284     [ \ predicate-see-test see ] with-string-writer
 285 ] unit-test
 286
 287 INTERSECTION: intersection-see-test sequence number ;
 288
 289 [ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
 290     [ \ intersection-see-test see ] with-string-writer
 291 ] unit-test
 292
 293 [ ] [ \ compose see ] unit-test
 294 [ ] [ \ curry see ] unit-test
 295
 296 [ "POSTPONE: [" ] [ \ [ unparse ] unit-test
 297
 298 TUPLE: started-out-hustlin' ;
 299
 300 GENERIC: ended-up-ballin' ( a -- b )
 301
 302 M: started-out-hustlin' ended-up-ballin' ; inline
 303
 304 [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
 305     [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
 306 ] unit-test