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.tuple classes.tuple.private colors colors.constants
   5 combinators continuations effects generic hashtables io
   6 io.pathnames io.styles kernel make math math.order math.parser
   7 namespaces prettyprint.config prettyprint.custom
   8 prettyprint.sections prettyprint.stylesheet quotations sbufs
   9 sequences strings vectors words words.symbol hash-sets ;
  10 FROM: sets => members ;
  11 IN: prettyprint.backend
  12
  13 M: effect pprint* effect>string "(" ")" surround 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 : word-name* ( word -- str )
  26     name>> "( no name )" or ;
  27
  28 : pprint-word ( word -- )
  29     [ record-vocab ]
  30     [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
  31
  32 : pprint-prefix ( word quot -- )
  33     <block swap pprint-word call block> ; inline
  34
  35 M: parsing-word pprint*
  36     \ POSTPONE: [ pprint-word ] pprint-prefix ;
  37
  38 M: word pprint*
  39     [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
  40
  41 M: method pprint*
  42     [
  43         [
  44             [ "M\\ " % "method-class" word-prop word-name* % ]
  45             [ " " % "method-generic" word-prop word-name* % ] bi
  46         ] "" make
  47     ] [ word-style ] bi styled-text ;
  48
  49 M: real pprint*
  50     number-base get {
  51         { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
  52         {  8 [ \ OCT: [  8 >base text ] pprint-prefix ] }
  53         {  2 [ \ BIN: [  2 >base text ] pprint-prefix ] }
  54         [ drop number>string text ]
  55     } case ;
  56
  57 M: float pprint*
  58     dup fp-nan? [
  59         \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
  60     ] [
  61         number-base get {
  62             { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
  63             [ drop number>string text ]
  64         } case
  65     ] if ;
  66
  67 M: f pprint* drop \ f pprint-word ;
  68
  69 : pprint-effect ( effect -- )
  70     [ effect>string ] [ effect-style ] bi styled-text ;
  71
  72 ! Strings
  73 : ch>ascii-escape ( ch -- str )
  74     H{
  75         { CHAR: \a CHAR: a  }
  76         { CHAR: \e CHAR: e  }
  77         { CHAR: \n CHAR: n  }
  78         { CHAR: \r CHAR: r  }
  79         { CHAR: \t CHAR: t  }
  80         { CHAR: \0 CHAR: 0  }
  81         { CHAR: \\ CHAR: \\ }
  82         { CHAR: \" CHAR: \" }
  83     } at ;
  84
  85 : unparse-ch ( ch -- )
  86     dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
  87
  88 : do-string-limit ( str -- trimmed )
  89     string-limit? get [
  90         dup length margin get > [
  91             margin get 3 - head "..." append
  92         ] when
  93     ] when ;
  94
  95 : unparse-string ( str prefix suffix -- str )
  96     [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
  97
  98 : pprint-string ( obj str prefix suffix -- )
  99     unparse-string swap string-style styled-text ;
 100
 101 M: string pprint*
 102     dup "\"" "\"" pprint-string ;
 103
 104 M: sbuf pprint*
 105     dup "SBUF\" " "\"" pprint-string ;
 106
 107 M: pathname pprint*
 108     dup string>> "P\" " "\"" pprint-string ;
 109
 110 ! Sequences
 111 : nesting-limit? ( -- ? )
 112     nesting-limit get dup [ pprinter-stack get length < ] when ;
 113
 114 : present-text ( str obj -- )
 115     presented associate styled-text ;
 116
 117 : check-recursion ( obj quot -- )
 118     nesting-limit? [
 119         drop
 120         [ class name>> "~" dup surround ] keep present-text
 121     ] [
 122         over recursion-check get member-eq? [
 123             drop "~circularity~" swap present-text
 124         ] [
 125             over recursion-check get push
 126             call
 127             recursion-check get pop*
 128         ] if
 129     ] if ; inline
 130
 131 : filter-tuple-assoc ( slot,value -- name,value )
 132     [ [ initial>> ] dip = not ] assoc-filter
 133     [ [ name>> ] dip ] assoc-map ;
 134
 135 : tuple>assoc ( tuple -- assoc )
 136     [ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
 137
 138 : pprint-slot-value ( name value -- )
 139     <flow \ { pprint-word
 140     [ text ] [ f <inset pprint* block> ] bi*
 141     \ } pprint-word block> ;
 142
 143 : (pprint-tuple) ( opener class slots closer -- )
 144     <flow {
 145         [ pprint-word ]
 146         [ pprint-word ]
 147         [ t <inset [ pprint-slot-value ] assoc-each block> ]
 148         [ pprint-word ]
 149     } spread block> ;
 150
 151 : ?pprint-tuple ( tuple quot -- )
 152     [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
 153
 154 : pprint-tuple ( tuple -- )
 155     [ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
 156
 157 M: tuple pprint*
 158     pprint-tuple ;
 159
 160 : recover-pprint ( try recovery -- )
 161     pprinter-stack get clone
 162     [ pprinter-stack set ] curry prepose recover ; inline
 163
 164 : pprint-c-object ( object content-quot pointer-quot -- )
 165     [ c-object-pointers? get ] 2dip
 166     [ nip ]
 167     [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
 168
 169 : do-length-limit ( seq -- trimmed n/f )
 170     length-limit get dup [
 171         over length over [-]
 172         dup zero? [ 2drop f ] [ [ head-slice ] dip ] if
 173     ] when ;
 174
 175 : pprint-elements ( seq -- )
 176     do-length-limit
 177     [ [ pprint* ] each ] dip
 178     [ number>string "~" " more~" surround text ] when* ;
 179
 180 M: quotation pprint-delims drop \ [ \ ] ;
 181 M: curry pprint-delims drop \ [ \ ] ;
 182 M: compose pprint-delims drop \ [ \ ] ;
 183 M: array pprint-delims drop \ { \ } ;
 184 M: byte-array pprint-delims drop \ B{ \ } ;
 185 M: byte-vector pprint-delims drop \ BV{ \ } ;
 186 M: vector pprint-delims drop \ V{ \ } ;
 187 M: hashtable pprint-delims drop \ H{ \ } ;
 188 M: tuple pprint-delims drop \ T{ \ } ;
 189 M: wrapper pprint-delims drop \ W{ \ } ;
 190 M: callstack pprint-delims drop \ CS{ \ } ;
 191 M: hash-set pprint-delims drop \ HS{ \ } ;
 192
 193 M: object >pprint-sequence ;
 194 M: vector >pprint-sequence ;
 195 M: byte-vector >pprint-sequence ;
 196 M: callable >pprint-sequence ;
 197 M: hashtable >pprint-sequence >alist ;
 198 M: wrapper >pprint-sequence wrapped>> 1array ;
 199 M: callstack >pprint-sequence callstack>array ;
 200 M: hash-set >pprint-sequence members ;
 201
 202 : class-slot-sequence ( class slots -- sequence )
 203     [ 1array ] [ [ f 2array ] dip append ] if-empty ;
 204
 205 M: tuple >pprint-sequence
 206     [ class ] [ tuple-slots ] bi class-slot-sequence ;
 207
 208 M: object pprint-narrow? drop f ;
 209 M: byte-vector pprint-narrow? drop f ;
 210 M: array pprint-narrow? drop t ;
 211 M: vector pprint-narrow? drop t ;
 212 M: hashtable pprint-narrow? drop t ;
 213 M: tuple pprint-narrow? drop t ;
 214
 215 M: object pprint-object ( obj -- )
 216     [
 217         <flow
 218         dup pprint-delims [
 219             pprint-word
 220             dup pprint-narrow? <inset
 221             >pprint-sequence pprint-elements
 222             block>
 223         ] dip pprint-word block>
 224     ] check-recursion ;
 225
 226 M: object pprint* pprint-object ;
 227 M: vector pprint* pprint-object ;
 228 M: byte-vector pprint* pprint-object ;
 229 M: hashtable pprint* pprint-object ;
 230 M: curry pprint* pprint-object ;
 231 M: compose pprint* pprint-object ;
 232 M: hash-set pprint* pprint-object ;
 233
 234 M: wrapper pprint*
 235     {
 236         { [ dup wrapped>> method? ] [ wrapped>> pprint* ] }
 237         { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
 238         [ pprint-object ]
 239     } cond ;