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