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