basis/prettyprint/backend/backend.factor

   1 ! Copyright (C) 2003, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-arrays byte-vectors classes
   4 classes.algebra.private classes.maybe classes.private
   5 classes.tuple combinators combinators.short-circuit
   6 continuations effects generic hash-sets hashtables io.pathnames
   7 io.styles kernel lists make math math.order math.parser
   8 namespaces prettyprint.config prettyprint.custom
   9 prettyprint.sections prettyprint.stylesheet quotations sbufs
  10 sequences strings vectors words ;
  11 QUALIFIED: sets
  12 IN: prettyprint.backend
  13
  14 M: effect pprint* effect>string text ;
  15
  16 : ?effect-height ( word -- n )
  17     stack-effect [ effect-height ] [ 0 ] if* ;
  18
  19 : ?start-group ( word -- )
  20     ?effect-height 0 > [ start-group ] when ;
  21
  22 : ?end-group ( word -- )
  23     ?effect-height 0 < [ end-group ] when ;
  24
  25 ! Atoms
  26 GENERIC: word-name* ( obj -- str )
  27
  28 M: maybe word-name*
  29     class-name "maybe{ " " }" surround ;
  30
  31 M: anonymous-complement word-name*
  32     class-name "not{ " " }" surround ;
  33
  34 M: anonymous-union word-name*
  35     class-name "union{ " " }" surround ;
  36
  37 M: anonymous-intersection word-name*
  38     class-name "intersection{ " " }" surround ;
  39
  40 M: word word-name*
  41     [ name>> "( no name )" or ] [ record-vocab ] bi ;
  42
  43 : pprint-word ( word -- )
  44     [ word-name* ] [ word-style ] bi styled-text ;
  45
  46 GENERIC: pprint-class ( obj -- )
  47
  48 M: classoid pprint-class pprint* ;
  49
  50 M: class pprint-class \ f or pprint-word ;
  51
  52 M: word pprint-class pprint-word ;
  53
  54 : pprint-prefix ( word quot -- )
  55     <block swap pprint-word call block> ; inline
  56
  57 M: parsing-word pprint*
  58     \ POSTPONE: [ pprint-word ] pprint-prefix ;
  59
  60 M: word pprint*
  61     [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
  62
  63 M: method pprint*
  64     <block
  65     [ \ M\ pprint-word "method-class" word-prop pprint* ]
  66     [ "method-generic" word-prop pprint-word ] bi
  67     block> ;
  68
  69 : pprint-prefixed-number ( n quot: ( n -- n' ) pre -- )
  70     pick neg?
  71     [ [ neg ] [ call ] [ prepend ] tri* "-" prepend text ]
  72     [ [ call ] [ prepend ] bi* text ] if ; inline
  73
  74 ERROR: unsupported-number-base n base ;
  75
  76 M: real pprint*
  77     number-base get {
  78         { 10 [ number>string text ] }
  79         { 16 [ [ >hex ] "0x" pprint-prefixed-number ] }
  80         {  8 [ [ >oct ] "0o" pprint-prefixed-number ] }
  81         {  2 [ [ >bin ] "0b" pprint-prefixed-number ] }
  82         [ unsupported-number-base ]
  83     } case ;
  84
  85 M: float pprint*
  86     {
  87         { [ dup 0/0. fp-bitwise= ] [ drop "0/0." text ] }
  88         { [ dup -0/0. fp-bitwise= ] [ drop "-0/0." text ] }
  89         { [ dup fp-nan? ] [
  90             \ NAN: [
  91                 [ fp-nan-payload ] [ fp-sign ] bi
  92                 [ 0xfffffffffffff bitxor 1 + neg ] when >hex text
  93             ] pprint-prefix
  94         ] }
  95         { [ dup 1/0. = ] [ drop "1/0." text ] }
  96         { [ dup -1/0. = ] [ drop "-1/0." text ] }
  97         { [ dup 0.0 fp-bitwise= ] [ drop "0.0" text ] }
  98         { [ dup -0.0 fp-bitwise= ] [ drop "-0.0" text ] }
  99         [ call-next-method ]
 100     } cond ;
 101
 102 M: f pprint* drop \ f pprint-word ;
 103
 104 : pprint-effect ( effect -- )
 105     [ effect>string ] [ effect-style ] bi styled-text ;
 106
 107 ! Strings
 108 : ch>ascii-escape ( ch -- ch' ? )
 109     H{
 110         { CHAR: \a CHAR: a  }
 111         { CHAR: \b CHAR: b  }
 112         { CHAR: \e CHAR: e  }
 113         { CHAR: \f CHAR: f  }
 114         { CHAR: \n CHAR: n  }
 115         { CHAR: \r CHAR: r  }
 116         { CHAR: \t CHAR: t  }
 117         { CHAR: \v CHAR: v  }
 118         { CHAR: \0 CHAR: 0  }
 119         { CHAR: \\ CHAR: \\ }
 120         { CHAR: \" CHAR: \" }
 121     } ?at ; inline
 122
 123 : unparse-ch ( ch -- )
 124     ch>ascii-escape [ CHAR: \\ , , ] [
 125         dup 32 < [ dup 16 < "\\x0" "\\x" ? % >hex % ] [ , ] if
 126     ] if ;
 127
 128 : do-string-limit ( str -- trimmed )
 129     string-limit? get [
 130         dup length margin get > [
 131             margin get 3 - head "..." append
 132         ] when
 133     ] when ;
 134
 135 : unparse-string ( str prefix suffix -- str )
 136     [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
 137
 138 : pprint-string ( obj str prefix suffix -- )
 139     unparse-string swap string-style styled-text ;
 140
 141 M: string pprint*
 142     dup "\"" "\"" pprint-string ;
 143
 144 M: sbuf pprint*
 145     dup "SBUF\" " "\"" pprint-string ;
 146
 147 M: pathname pprint*
 148     dup string>> "P\" " "\"" pprint-string ;
 149
 150 ! Sequences
 151 : nesting-limit? ( -- ? )
 152     nesting-limit get dup [ pprinter-stack get length < ] when ;
 153
 154 : present-text ( str obj -- )
 155     presented associate styled-text ;
 156
 157 : check-recursion ( obj quot: ( obj -- ) -- )
 158     nesting-limit? [
 159         drop
 160         [ class-of name>> "~" 1surround ] keep present-text
 161     ] [
 162         over recursion-check get member-eq? [
 163             drop "~circularity~" swap present-text
 164         ] [
 165             over recursion-check get push
 166             call
 167             recursion-check get pop*
 168         ] if
 169     ] if ; inline
 170
 171 : filter-tuple-assoc ( slot,value -- name,value )
 172     [ [ initial>> ] dip = ] assoc-reject
 173     [ [ name>> ] dip ] assoc-map ;
 174
 175 : tuple>assoc ( tuple -- assoc )
 176     [ class-of all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
 177
 178 : pprint-slot-value ( name value -- )
 179     <flow \ { pprint-word
 180     [ text ] [ f <inset pprint* block> ] bi*
 181     \ } pprint-word block> ;
 182
 183 : (pprint-tuple) ( opener class slots closer -- )
 184     <flow {
 185         [ pprint-word ]
 186         [ pprint-word ]
 187         [ t <inset [ pprint-slot-value ] assoc-each block> ]
 188         [ pprint-word ]
 189     } spread block> ;
 190
 191 : ?pprint-tuple ( tuple quot -- )
 192     [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
 193
 194 : pprint-tuple ( tuple -- )
 195     [ [ \ T{ ] dip [ class-of ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
 196
 197 M: tuple pprint*
 198     pprint-tuple ;
 199
 200 : recover-pprint ( try recovery -- )
 201     pprinter-stack get clone
 202     [ pprinter-stack set ] curry prepose recover ; inline
 203
 204 : pprint-c-object ( object content-quot pointer-quot -- )
 205     [ c-object-pointers? get ] 2dip
 206     [ nip ]
 207     [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
 208
 209 : do-length-limit ( seq -- trimmed n/f )
 210     length-limit get dup [
 211         1 - over length over [-]
 212         dup 1 > [ [ head-slice ] dip ] [ 2drop f ] if
 213     ] when ;
 214
 215 : pprint-elements ( seq -- )
 216     do-length-limit
 217     [ [ pprint* ] each ] dip
 218     [ number>string "~" " more~" surround text ] when* ;
 219
 220 M: quotation pprint-delims drop \ [ \ ] ;
 221 M: curried pprint-delims drop \ [ \ ] ;
 222 M: composed pprint-delims drop \ [ \ ] ;
 223 M: array pprint-delims drop \ { \ } ;
 224 M: byte-array pprint-delims drop \ B{ \ } ;
 225 M: byte-vector pprint-delims drop \ BV{ \ } ;
 226 M: vector pprint-delims drop \ V{ \ } ;
 227 M: cons-state pprint-delims drop \ L{ \ } ;
 228 M: +nil+ pprint-delims drop \ L{ \ } ;
 229 M: hashtable pprint-delims drop \ H{ \ } ;
 230 M: tuple pprint-delims drop \ T{ \ } ;
 231 M: wrapper pprint-delims drop \ W{ \ } ;
 232 M: callstack pprint-delims drop \ CS{ \ } ;
 233 M: hash-set pprint-delims drop \ HS{ \ } ;
 234 M: anonymous-union pprint-delims drop \ union{ \ } ;
 235 M: anonymous-intersection pprint-delims drop \ intersection{ \ } ;
 236 M: anonymous-complement pprint-delims drop \ not{ \ } ;
 237 M: maybe pprint-delims drop \ maybe{ \ } ;
 238
 239 M: object >pprint-sequence ;
 240 M: vector >pprint-sequence ;
 241 M: byte-vector >pprint-sequence ;
 242 M: callable >pprint-sequence ;
 243 M: hashtable >pprint-sequence >alist ;
 244 M: wrapper >pprint-sequence wrapped>> 1array ;
 245 M: callstack >pprint-sequence callstack>array ;
 246 M: hash-set >pprint-sequence sets:members ;
 247 M: anonymous-union >pprint-sequence members>> ;
 248 M: anonymous-intersection >pprint-sequence participants>> ;
 249 M: anonymous-complement >pprint-sequence class>> 1array ;
 250 M: maybe >pprint-sequence class>> 1array ;
 251
 252 : class-slot-sequence ( class slots -- sequence )
 253     [ 1array ] [ [ f 2array ] dip append ] if-empty ;
 254
 255 M: tuple >pprint-sequence
 256     [ class-of ] [ tuple-slots ] bi class-slot-sequence ;
 257
 258 M: object pprint-narrow? drop f ;
 259 M: byte-vector pprint-narrow? drop f ;
 260 M: array pprint-narrow? drop t ;
 261 M: vector pprint-narrow? drop t ;
 262 M: hashtable pprint-narrow? drop t ;
 263 M: tuple pprint-narrow? drop t ;
 264
 265 M: object pprint-object
 266     [
 267         <flow
 268         dup pprint-delims [
 269             pprint-word
 270             dup pprint-narrow? <inset
 271             >pprint-sequence pprint-elements
 272             block>
 273         ] dip pprint-word block>
 274     ] check-recursion ;
 275
 276 M: object pprint* pprint-object ;
 277 M: vector pprint* pprint-object ;
 278 M: byte-vector pprint* pprint-object ;
 279
 280 M: cons-state pprint*
 281     [
 282         <flow
 283         dup pprint-delims [
 284             pprint-word
 285             dup pprint-narrow? <inset
 286             [
 287                 building get
 288                 length-limit get
 289                 '[ dup cons-state? _ length _ < and ]
 290                 [ uncons swap , ] while
 291             ] { } make
 292             [ pprint* ] each
 293             dup list? [
 294                 nil? [ "~more~" text ] unless
 295             ] [
 296                 "." text pprint*
 297             ] if
 298             block>
 299         ] dip pprint-word block>
 300     ] check-recursion ;
 301
 302 M: +nil+ pprint*
 303     <flow pprint-delims [ pprint-word ] bi@ block> ;
 304
 305 : with-extra-nesting-level ( quot -- )
 306     nesting-limit [ dup [ 1 + ] [ f ] if* ] change
 307     [ nesting-limit set ] curry finally ; inline
 308
 309 M: hashtable pprint*
 310     [ pprint-object ] with-extra-nesting-level ;
 311 M: curried pprint* pprint-object ;
 312 M: composed pprint* pprint-object ;
 313 M: hash-set pprint* pprint-object ;
 314 M: anonymous-union pprint* pprint-object ;
 315 M: anonymous-intersection pprint* pprint-object ;
 316 M: anonymous-complement pprint* pprint-object ;
 317 M: maybe pprint* pprint-object ;
 318
 319 M: wrapper pprint*
 320     {
 321         { [ dup wrapped>> method? ] [ wrapped>> pprint* ] }
 322         { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
 323         [ pprint-object ]
 324     } cond ;