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