core/prettyprint/backend.factor

   1 ! Copyright (C) 2003, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: prettyprint-internals
   4 USING: arrays generic hashtables io kernel math
   5 namespaces parser sequences strings styles vectors words
   6 prettyprint ;
   7
   8 GENERIC: pprint* ( obj -- )
   9
  10 ! Atoms
  11 M: byte-array pprint* drop "( byte array )" text ;
  12
  13 : word-style ( word -- style )
  14     [
  15         dup presented set
  16         parsing? [ bold font-style set ] when
  17     ] make-hash ;
  18
  19 : pprint-word ( word -- )
  20     dup word-name [ "( no name )" ] unless*
  21     swap word-style styled-text ;
  22
  23 M: word pprint*
  24     dup parsing? [
  25         H{ } <flow \ POSTPONE: pprint-word pprint-word block>
  26     ] [
  27         pprint-word
  28     ] if ;
  29
  30 M: real pprint* number>string text ;
  31
  32 M: f pprint* drop \ f pprint-word ;
  33
  34 ! Strings
  35 : ch>ascii-escape ( ch -- str )
  36     H{
  37         { CHAR: \e "\\e"  }
  38         { CHAR: \n "\\n"  }
  39         { CHAR: \r "\\r"  }
  40         { CHAR: \t "\\t"  }
  41         { CHAR: \0 "\\0"  }
  42         { CHAR: \\ "\\\\" }
  43         { CHAR: \" "\\\"" }
  44     } hash ;
  45
  46 : ch>unicode-escape ( ch -- str )
  47     >hex 4 CHAR: 0 pad-left "\\u" swap append ;
  48
  49 : unparse-ch ( ch -- )
  50     dup quotable? [
  51         ,
  52     ] [
  53         dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
  54     ] if ;
  55
  56 : do-string-limit ( str -- trimmed )
  57     string-limit get [
  58         dup length margin get > [
  59             margin get 3 - head "..." append
  60         ] when
  61     ] when ;
  62
  63 : pprint-string ( str prefix -- )
  64     [ % [ unparse-ch ] each CHAR: " , ] "" make
  65     do-string-limit text ;
  66
  67 M: string pprint* "\"" pprint-string ;
  68
  69 M: sbuf pprint* "SBUF\" " pprint-string ;
  70
  71 ! Sequences
  72 : nesting-limit? ( -- ? )
  73     nesting-limit get dup [ pprinter-stack get length < ] when ;
  74
  75 : truncated-nesting ( obj str -- )
  76     swap presented associate styled-text ;
  77
  78 : check-recursion ( obj quot -- )
  79     nesting-limit? [
  80         drop "#" truncated-nesting
  81     ] [
  82         over recursion-check get memq? [
  83             drop "&" truncated-nesting
  84         ] [
  85             over recursion-check get push
  86             call
  87             recursion-check get pop*
  88         ] if
  89     ] if ; inline
  90
  91 : length-limit? ( seq -- trimmed ? )
  92     length-limit get dup
  93     [ over length over > [ head t ] [ drop f ] if ]
  94     [ drop f ] if ;
  95
  96 : hilite-style ( -- hash )
  97     H{
  98         { background { 0.9 0.9 0.9 1 } }
  99         { highlight t }
 100     } ;
 101
 102 : pprint-hilite ( object n -- )
 103     hilite-index get = [
 104         hilite-style <flow pprint* block>
 105     ] [
 106         pprint*
 107     ] if ;
 108
 109 : pprint-elements ( seq -- )
 110     length-limit? >r dup hilite-quotation get eq? [
 111         dup length [ pprint-hilite ] 2each
 112     ] [
 113         [ pprint* ] each
 114     ] if r> [ "..." text ] when ;
 115
 116 GENERIC: >pprint-sequence ( obj -- seq start end narrow? )
 117
 118 M: complex >pprint-sequence >rect 2array \ C{ \ } f ;
 119
 120 M: quotation >pprint-sequence \ [ \ ] f ;
 121
 122 M: array >pprint-sequence \ { \ } t ;
 123
 124 M: vector >pprint-sequence \ V{ \ } t ;
 125
 126 M: hashtable >pprint-sequence hash>alist \ H{ \ } t ;
 127
 128 M: tuple >pprint-sequence tuple>array \ T{ \ } t ;
 129
 130 M: wrapper >pprint-sequence wrapped 1array \ W{ \ } f ;
 131
 132 : pprint-object ( obj -- )
 133     [
 134         >pprint-sequence H{ } <flow
 135         rot [ pprint-word ] when*
 136         [ H{ } <narrow ] [ H{ } <inset ] if
 137         swap pprint-elements
 138         block> [ pprint-word ] when* block>
 139     ] check-recursion ;
 140
 141 M: object pprint* pprint-object ;
 142
 143 M: wrapper pprint*
 144     dup wrapped word? [
 145         \ \ pprint-word wrapped pprint-word
 146     ] [
 147         pprint-object
 148     ] if ;