core/prettyprint/backend/backend.factor

   1 ! Copyright (C) 2003, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays byte-arrays bit-arrays generic hashtables io
   4 assocs kernel math namespaces sequences strings sbufs io.styles
   5 vectors words prettyprint.config prettyprint.sections quotations
   6 io io.files math.parser effects tuples classes float-arrays ;
   7 IN: prettyprint.backend
   8
   9 GENERIC: pprint* ( obj -- )
  10
  11 : ?effect-height ( word -- n )
  12     stack-effect [ effect-height ] [ 0 ] if* ;
  13
  14 : ?start-group ( word -- )
  15     ?effect-height 0 > [ start-group ] when ;
  16
  17 : ?end-group ( word -- )
  18     ?effect-height 0 < [ end-group ] when ;
  19
  20 \ >r hard "break-before" set-word-prop
  21 \ r> hard "break-after" set-word-prop
  22
  23 ! Atoms
  24 : word-style ( word -- style )
  25     [
  26         dup presented set
  27         dup parsing? over delimiter? rot t eq? or or
  28         [ bold font-style set ] when
  29     ] H{ } make-assoc ;
  30
  31 : word-name* ( word -- str )
  32     word-name "( no name )" or ;
  33
  34 : pprint-word ( word -- )
  35     dup record-vocab
  36     dup word-name* swap word-style styled-text ;
  37
  38 : pprint-prefix ( word quot -- )
  39     <block swap pprint-word call block> ; inline
  40
  41 M: word pprint*
  42     dup parsing? [
  43         \ POSTPONE: [ pprint-word ] pprint-prefix
  44     ] [
  45         dup "break-before" word-prop break
  46         dup pprint-word
  47         dup ?start-group dup ?end-group
  48         "break-after" word-prop break
  49     ] if ;
  50
  51 M: real pprint* number>string text ;
  52
  53 M: f pprint* drop \ f pprint-word ;
  54
  55 ! Strings
  56 : ch>ascii-escape ( ch -- str )
  57     H{
  58         { CHAR: \e "\\e"  }
  59         { CHAR: \n "\\n"  }
  60         { CHAR: \r "\\r"  }
  61         { CHAR: \t "\\t"  }
  62         { CHAR: \0 "\\0"  }
  63         { CHAR: \\ "\\\\" }
  64         { CHAR: \" "\\\"" }
  65     } at ;
  66
  67 : ch>unicode-escape ( ch -- str )
  68     >hex 4 CHAR: 0 pad-left "\\u" swap append ;
  69
  70 : unparse-ch ( ch -- )
  71     dup quotable? [
  72         ,
  73     ] [
  74         dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
  75     ] 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         { 0.3 0.3 0.3 1.0 } foreground set
  88     ] H{ } make-assoc ;
  89
  90 : unparse-string ( str prefix -- str )
  91     [
  92         % do-string-limit [ unparse-ch ] each CHAR: " ,
  93     ] "" make ;
  94
  95 : pprint-string ( obj str prefix -- )
  96     unparse-string swap string-style styled-text ;
  97
  98 M: string pprint* dup "\"" pprint-string ;
  99
 100 M: sbuf pprint* dup "SBUF\" " pprint-string ;
 101
 102 M: pathname pprint* dup pathname-string "P\" " pprint-string ;
 103
 104 ! Sequences
 105 : nesting-limit? ( -- ? )
 106     nesting-limit get dup [ pprinter-stack get length < ] when ;
 107
 108 : present-text ( str obj -- )
 109     presented associate styled-text ;
 110
 111 : check-recursion ( obj quot -- )
 112     nesting-limit? [
 113         drop
 114         "~" over class word-name "~" 3append
 115         swap present-text
 116     ] [
 117         over recursion-check get memq? [
 118             drop "~circularity~" swap present-text
 119         ] [
 120             over recursion-check get push
 121             call
 122             recursion-check get pop*
 123         ] if
 124     ] if ; inline
 125
 126 : do-length-limit ( seq -- trimmed n/f )
 127     length-limit get dup [
 128         over length over [-]
 129         dup zero? [ 2drop f ] [ >r head r> ] if
 130     ] when ;
 131
 132 : pprint-hilite ( n object -- )
 133     pprint* hilite-index get = [ hilite ] when ;
 134
 135 : pprint-elements ( seq -- )
 136     do-length-limit >r dup hilite-quotation get eq? [
 137         [ length ] keep [ pprint-hilite ] 2each
 138     ] [
 139         [ pprint* ] each
 140     ] if
 141     r> [ "~" swap number>string " more~" 3append text ] when* ;
 142
 143 GENERIC: pprint-delims ( obj -- start end )
 144
 145 M: complex pprint-delims drop \ C{ \ } ;
 146 M: quotation pprint-delims drop \ [ \ ] ;
 147 M: curry pprint-delims drop \ [ \ ] ;
 148 M: array pprint-delims drop \ { \ } ;
 149 M: byte-array pprint-delims drop \ B{ \ } ;
 150 M: bit-array pprint-delims drop \ ?{ \ } ;
 151 M: float-array pprint-delims drop \ F{ \ } ;
 152 M: vector pprint-delims drop \ V{ \ } ;
 153 M: hashtable pprint-delims drop \ H{ \ } ;
 154 M: tuple pprint-delims drop \ T{ \ } ;
 155 M: wrapper pprint-delims drop \ W{ \ } ;
 156 M: callstack pprint-delims drop \ CS{ \ } ;
 157
 158 GENERIC: >pprint-sequence ( obj -- seq )
 159
 160 M: object >pprint-sequence ;
 161
 162 M: complex >pprint-sequence >rect 2array ;
 163 M: hashtable >pprint-sequence >alist ;
 164 M: tuple >pprint-sequence tuple>array ;
 165 M: wrapper >pprint-sequence wrapped 1array ;
 166 M: callstack >pprint-sequence callstack>array ;
 167
 168 GENERIC: pprint-narrow? ( obj -- ? )
 169
 170 M: object pprint-narrow? drop f ;
 171
 172 M: array pprint-narrow? drop t ;
 173 M: vector pprint-narrow? drop t ;
 174 M: hashtable pprint-narrow? drop t ;
 175 M: tuple pprint-narrow? drop t ;
 176
 177 : pprint-object ( obj -- )
 178     [
 179         <flow
 180         dup pprint-delims >r pprint-word
 181         dup pprint-narrow? <inset
 182         >pprint-sequence pprint-elements
 183         block> r> pprint-word block>
 184     ] check-recursion ;
 185
 186 M: object pprint* pprint-object ;
 187
 188 M: wrapper pprint*
 189     dup wrapped word? [
 190         <block \ \ pprint-word wrapped pprint-word block>
 191     ] [
 192         pprint-object
 193     ] if ;