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