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 : pprint-nan? ( f -- ? )
  86     { [ fp-nan? ] [ 0/0. fp-bitwise= not ] [ -0/0. fp-bitwise= not ] } 1&& ;
  87
  88 M: float pprint*
  89     dup pprint-nan? [
  90         \ NAN: [
  91             [ fp-nan-payload ] [ fp-sign ] bi
  92             [ 0xfffffffffffff bitxor 1 + neg ] when >hex text
  93         ] pprint-prefix
  94     ] [
  95         call-next-method
  96     ] if ;
  97
  98 M: f pprint* drop \ f pprint-word ;
  99
 100 : pprint-effect ( effect -- )
 101     [ effect>string ] [ effect-style ] bi styled-text ;
 102
 103 ! Strings
 104 : ch>ascii-escape ( ch -- ch' ? )
 105     H{
 106         { CHAR: \a CHAR: a  }
 107         { CHAR: \b CHAR: b  }
 108         { CHAR: \e CHAR: e  }
 109         { CHAR: \f CHAR: f  }
 110         { CHAR: \n CHAR: n  }
 111         { CHAR: \r CHAR: r  }
 112         { CHAR: \t CHAR: t  }
 113         { CHAR: \v CHAR: v  }
 114         { CHAR: \0 CHAR: 0  }
 115         { CHAR: \\ CHAR: \\ }
 116         { CHAR: \" CHAR: \" }
 117     } ?at ; inline
 118
 119 : unparse-ch ( ch -- )
 120     ch>ascii-escape [ CHAR: \\ , , ] [
 121         dup 32 < [ dup 16 < "\\x0" "\\x" ? % >hex % ] [ , ] if
 122     ] if ;
 123
 124 : do-string-limit ( str -- trimmed )
 125     string-limit? get [
 126         dup length margin get > [
 127             margin get 3 - head "..." append
 128         ] when
 129     ] when ;
 130
 131 : unparse-string ( str prefix suffix -- str )
 132     [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
 133
 134 : pprint-string ( obj str prefix suffix -- )
 135     unparse-string swap string-style styled-text ;
 136
 137 M: string pprint*
 138     dup "\"" "\"" pprint-string ;
 139
 140 M: sbuf pprint*
 141     dup "SBUF\" " "\"" pprint-string ;
 142
 143 M: pathname pprint*
 144     dup string>> "P\" " "\"" pprint-string ;
 145
 146 ! Sequences
 147 : nesting-limit? ( -- ? )
 148     nesting-limit get dup [ pprinter-stack get length < ] when ;
 149
 150 : present-text ( str obj -- )
 151     presented associate styled-text ;
 152
 153 : check-recursion ( obj quot: ( obj -- ) -- )
 154     nesting-limit? [
 155         drop
 156         [ class-of name>> "~" dup surround ] keep present-text
 157     ] [
 158         over recursion-check get member-eq? [
 159             drop "~circularity~" swap present-text
 160         ] [
 161             over recursion-check get push
 162             call
 163             recursion-check get pop*
 164         ] if
 165     ] if ; inline
 166
 167 : filter-tuple-assoc ( slot,value -- name,value )
 168     [ [ initial>> ] dip = ] assoc-reject
 169     [ [ name>> ] dip ] assoc-map ;
 170
 171 : tuple>assoc ( tuple -- assoc )
 172     [ class-of all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
 173
 174 : pprint-slot-value ( name value -- )
 175     <flow \ { pprint-word
 176     [ text ] [ f <inset pprint* block> ] bi*
 177     \ } pprint-word block> ;
 178
 179 : (pprint-tuple) ( opener class slots closer -- )
 180     <flow {
 181         [ pprint-word ]
 182         [ pprint-word ]
 183         [ t <inset [ pprint-slot-value ] assoc-each block> ]
 184         [ pprint-word ]
 185     } spread block> ;
 186
 187 : ?pprint-tuple ( tuple quot -- )
 188     [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
 189
 190 : pprint-tuple ( tuple -- )
 191     [ [ \ T{ ] dip [ class-of ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
 192
 193 M: tuple pprint*
 194     pprint-tuple ;
 195
 196 : recover-pprint ( try recovery -- )
 197     pprinter-stack get clone
 198     [ pprinter-stack set ] curry prepose recover ; inline
 199
 200 : pprint-c-object ( object content-quot pointer-quot -- )
 201     [ c-object-pointers? get ] 2dip
 202     [ nip ]
 203     [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
 204
 205 : do-length-limit ( seq -- trimmed n/f )
 206     length-limit get dup [
 207         1 - over length over [-]
 208         dup 1 > [ [ head-slice ] dip ] [ 2drop f ] if
 209     ] when ;
 210
 211 : pprint-elements ( seq -- )
 212     do-length-limit
 213     [ [ pprint* ] each ] dip
 214     [ number>string "~" " more~" surround text ] when* ;
 215
 216 M: quotation pprint-delims drop \ [ \ ] ;
 217 M: curried pprint-delims drop \ [ \ ] ;
 218 M: composed pprint-delims drop \ [ \ ] ;
 219 M: array pprint-delims drop \ { \ } ;
 220 M: byte-array pprint-delims drop \ B{ \ } ;
 221 M: byte-vector pprint-delims drop \ BV{ \ } ;
 222 M: vector pprint-delims drop \ V{ \ } ;
 223 M: cons-state pprint-delims drop \ L{ \ } ;
 224 M: +nil+ pprint-delims drop \ L{ \ } ;
 225 M: hashtable pprint-delims drop \ H{ \ } ;
 226 M: tuple pprint-delims drop \ T{ \ } ;
 227 M: wrapper pprint-delims drop \ W{ \ } ;
 228 M: callstack pprint-delims drop \ CS{ \ } ;
 229 M: hash-set pprint-delims drop \ HS{ \ } ;
 230 M: anonymous-union pprint-delims drop \ union{ \ } ;
 231 M: anonymous-intersection pprint-delims drop \ intersection{ \ } ;
 232 M: anonymous-complement pprint-delims drop \ not{ \ } ;
 233 M: maybe pprint-delims drop \ maybe{ \ } ;
 234
 235 M: object >pprint-sequence ;
 236 M: vector >pprint-sequence ;
 237 M: byte-vector >pprint-sequence ;
 238 M: callable >pprint-sequence ;
 239 M: hashtable >pprint-sequence >alist ;
 240 M: wrapper >pprint-sequence wrapped>> 1array ;
 241 M: callstack >pprint-sequence callstack>array ;
 242 M: hash-set >pprint-sequence sets:members ;
 243 M: anonymous-union >pprint-sequence members>> ;
 244 M: anonymous-intersection >pprint-sequence participants>> ;
 245 M: anonymous-complement >pprint-sequence class>> 1array ;
 246 M: maybe >pprint-sequence class>> 1array ;
 247
 248 : class-slot-sequence ( class slots -- sequence )
 249     [ 1array ] [ [ f 2array ] dip append ] if-empty ;
 250
 251 M: tuple >pprint-sequence
 252     [ class-of ] [ tuple-slots ] bi class-slot-sequence ;
 253
 254 M: object pprint-narrow? drop f ;
 255 M: byte-vector pprint-narrow? drop f ;
 256 M: array pprint-narrow? drop t ;
 257 M: vector pprint-narrow? drop t ;
 258 M: hashtable pprint-narrow? drop t ;
 259 M: tuple pprint-narrow? drop t ;
 260
 261 M: object pprint-object
 262     [
 263         <flow
 264         dup pprint-delims [
 265             pprint-word
 266             dup pprint-narrow? <inset
 267             >pprint-sequence pprint-elements
 268             block>
 269         ] dip pprint-word block>
 270     ] check-recursion ;
 271
 272 M: object pprint* pprint-object ;
 273 M: vector pprint* pprint-object ;
 274 M: byte-vector pprint* pprint-object ;
 275
 276 M: cons-state pprint*
 277     [
 278         <flow
 279         dup pprint-delims [
 280             pprint-word
 281             dup pprint-narrow? <inset
 282             [
 283                 building get
 284                 length-limit get
 285                 '[ dup cons-state? _ length _ < and ]
 286                 [ uncons swap , ] while
 287             ] { } make
 288             [ pprint* ] each
 289             dup list? [
 290                 nil? [ "~more~" text ] unless
 291             ] [
 292                 "." text pprint*
 293             ] if
 294             block>
 295         ] dip pprint-word block>
 296     ] check-recursion ;
 297
 298 M: +nil+ pprint*
 299     <flow pprint-delims [ pprint-word ] bi@ block> ;
 300
 301 : with-extra-nesting-level ( quot -- )
 302     nesting-limit [ dup [ 1 + ] [ f ] if* ] change
 303     [ nesting-limit set ] curry finally ; inline
 304
 305 M: hashtable pprint*
 306     [ pprint-object ] with-extra-nesting-level ;
 307 M: curried pprint* pprint-object ;
 308 M: composed pprint* pprint-object ;
 309 M: hash-set pprint* pprint-object ;
 310 M: anonymous-union pprint* pprint-object ;
 311 M: anonymous-intersection pprint* pprint-object ;
 312 M: anonymous-complement pprint* pprint-object ;
 313 M: maybe pprint* pprint-object ;
 314
 315 M: wrapper pprint*
 316     {
 317         { [ dup wrapped>> method? ] [ wrapped>> pprint* ] }
 318         { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
 319         [ pprint-object ]
 320     } cond ;