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 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 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 ( a -- b )
 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 ( -- str )
 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 ( -- str )
 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 ( -- str )
 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 : narrow-test ( -- str )
 184     {
 185         "USING: arrays combinators continuations kernel sequences ;"
 186         "IN: prettyprint.tests"
 187         ": narrow-layout ( obj -- )"
 188         "    {"
 189         "        { [ dup continuation? ] [ append ] }"
 190         "        { [ dup not ] [ drop reverse ] }"
 191         "        { [ dup pair? ] [ delete ] }"
 192         "    } cond ;"
 193     } ;
 194
 195 [ t ] [
 196     "narrow-layout" narrow-test check-see
 197 ] unit-test
 198
 199 : another-narrow-test ( -- str )
 200     {
 201         "IN: prettyprint.tests"
 202         ": another-narrow-layout ( -- obj )"
 203         "    H{"
 204         "        { 1 2 }"
 205         "        { 3 4 }"
 206         "        { 5 6 }"
 207         "        { 7 8 }"
 208         "        { 9 10 }"
 209         "        { 11 12 }"
 210         "        { 13 14 }"
 211         "    } ;"
 212     } ;
 213
 214 [ t ] [
 215     "another-narrow-layout" another-narrow-test check-see
 216 ] unit-test
 217
 218 IN: prettyprint.tests
 219 TUPLE: class-see-layout ;
 220
 221 IN: prettyprint.tests
 222 GENERIC: class-see-layout ( x -- y )
 223
 224 USING: prettyprint.tests ;
 225 M: class-see-layout class-see-layout ;
 226
 227 [
 228     {
 229         "IN: prettyprint.tests"
 230         "TUPLE: class-see-layout ;"
 231         ""
 232         "IN: prettyprint.tests"
 233         "GENERIC: class-see-layout ( x -- y )"
 234         ""
 235     }
 236 ] [
 237     [ \ class-see-layout see ] with-string-writer "\n" split
 238 ] unit-test
 239
 240 [
 241     {
 242         "USING: prettyprint.tests ;"
 243         "M: class-see-layout class-see-layout ;"
 244         ""
 245     }
 246 ] [
 247     [ \ class-see-layout see-methods ] with-string-writer "\n" split
 248 ] unit-test
 249
 250 [ ] [ \ in>> synopsis drop ] unit-test
 251
 252 ! Regression
 253 [ t ] [
 254     "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
 255     dup eval
 256     "generic-decl-test" "prettyprint.tests" lookup
 257     [ see ] with-string-writer =
 258 ] unit-test
 259
 260 [ [ + ] ] [
 261     [ \ + (step-into-execute) ] (remove-breakpoints)
 262 ] unit-test
 263
 264 [ [ (step-into-execute) ] ] [
 265     [ (step-into-execute) ] (remove-breakpoints)
 266 ] unit-test
 267
 268 [ [ 2 2 + . ] ] [
 269     [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
 270 ] unit-test
 271
 272 [ [ 2 2 + . ] ] [
 273     [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
 274 ] unit-test
 275
 276 GENERIC: generic-see-test-with-f ( obj -- obj )
 277
 278 M: f generic-see-test-with-f ;
 279
 280 [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
 281     [ M\ f generic-see-test-with-f see ] with-string-writer
 282 ] unit-test
 283
 284 PREDICATE: predicate-see-test < integer even? ;
 285
 286 [ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
 287     [ \ predicate-see-test see ] with-string-writer
 288 ] unit-test
 289
 290 INTERSECTION: intersection-see-test sequence number ;
 291
 292 [ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
 293     [ \ intersection-see-test see ] with-string-writer
 294 ] unit-test
 295
 296 [ ] [ \ compose see ] unit-test
 297 [ ] [ \ curry see ] unit-test
 298
 299 [ "POSTPONE: [" ] [ \ [ unparse ] unit-test
 300
 301 TUPLE: started-out-hustlin' ;
 302
 303 GENERIC: ended-up-ballin' ( a -- b )
 304
 305 M: started-out-hustlin' ended-up-ballin' ; inline
 306
 307 [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
 308     [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
 309 ] unit-test