core/prettyprint/backend/backend.factor

   1 ! Copyright (C) 2003, 2008 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 classes.tuple
   7 classes.tuple.private classes float-arrays ;
   8 IN: prettyprint.backend
   9
  10 GENERIC: pprint* ( obj -- )
  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 \ >r hard "break-before" set-word-prop
  22 \ r> hard "break-after" set-word-prop
  23
  24 ! Atoms
  25 : word-style ( word -- style )
  26     dup "word-style" word-prop >hashtable [
  27         [
  28             dup presented set
  29             dup parsing? over delimiter? rot t eq? or or
  30             [ bold font-style set ] when
  31         ] bind
  32     ] keep ;
  33
  34 : word-name* ( word -- str )
  35     word-name "( no name )" or ;
  36
  37 : pprint-word ( word -- )
  38     dup record-vocab
  39     dup word-name* swap word-style styled-text ;
  40
  41 : pprint-prefix ( word quot -- )
  42     <block swap pprint-word call block> ; inline
  43
  44 M: word pprint*
  45     dup parsing? [
  46         \ POSTPONE: [ pprint-word ] pprint-prefix
  47     ] [
  48         dup "break-before" word-prop line-break
  49         dup pprint-word
  50         dup ?start-group dup ?end-group
  51         "break-after" word-prop line-break
  52     ] if ;
  53
  54 M: real pprint* number>string text ;
  55
  56 M: f pprint* drop \ f pprint-word ;
  57
  58 ! Strings
  59 : ch>ascii-escape ( ch -- str )
  60     H{
  61         { CHAR: \a CHAR: a  }
  62         { CHAR: \e CHAR: e  }
  63         { CHAR: \n CHAR: n  }
  64         { CHAR: \r CHAR: r  }
  65         { CHAR: \t CHAR: t  }
  66         { CHAR: \0 CHAR: 0  }
  67         { CHAR: \\ CHAR: \\ }
  68         { CHAR: \" CHAR: \" }
  69     } at ;
  70
  71 : unparse-ch ( ch -- )
  72     dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
  73
  74 : do-string-limit ( str -- trimmed )
  75     string-limit get [
  76         dup length margin get > [
  77             margin get 3 - head "..." append
  78         ] when
  79     ] when ;
  80
  81 : string-style ( obj -- hash )
  82     [
  83         presented set
  84         { 0.3 0.3 0.3 1.0 } foreground set
  85     ] H{ } make-assoc ;
  86
  87 : unparse-string ( str prefix suffix -- str )
  88     [ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
  89
  90 : pprint-string ( obj str prefix suffix -- )
  91     unparse-string swap string-style styled-text ;
  92
  93 M: string pprint*
  94     dup "\"" "\"" pprint-string ;
  95
  96 M: sbuf pprint*
  97     dup "SBUF\" " "\"" pprint-string ;
  98
  99 M: pathname pprint*
 100     dup pathname-string "P\" " "\"" pprint-string ;
 101
 102 ! Sequences
 103 : nesting-limit? ( -- ? )
 104     nesting-limit get dup [ pprinter-stack get length < ] when ;
 105
 106 : present-text ( str obj -- )
 107     presented associate styled-text ;
 108
 109 : check-recursion ( obj quot -- )
 110     nesting-limit? [
 111         drop
 112         "~" over class word-name "~" 3append
 113         swap present-text
 114     ] [
 115         over recursion-check get memq? [
 116             drop "~circularity~" swap present-text
 117         ] [
 118             over recursion-check get push
 119             call
 120             recursion-check get pop*
 121         ] if
 122     ] if ; inline
 123
 124 : do-length-limit ( seq -- trimmed n/f )
 125     length-limit get dup [
 126         over length over [-]
 127         dup zero? [ 2drop f ] [ >r head r> ] if
 128     ] when ;
 129
 130 : pprint-elements ( seq -- )
 131     do-length-limit >r
 132     [ pprint* ] each
 133     r> [ "~" swap number>string " more~" 3append text ] when* ;
 134
 135 GENERIC: pprint-delims ( obj -- start end )
 136
 137 M: quotation pprint-delims drop \ [ \ ] ;
 138 M: curry pprint-delims drop \ [ \ ] ;
 139 M: compose pprint-delims drop \ [ \ ] ;
 140 M: array pprint-delims drop \ { \ } ;
 141 M: byte-array pprint-delims drop \ B{ \ } ;
 142 M: bit-array pprint-delims drop \ ?{ \ } ;
 143 M: float-array pprint-delims drop \ F{ \ } ;
 144 M: vector pprint-delims drop \ V{ \ } ;
 145 M: hashtable pprint-delims drop \ H{ \ } ;
 146 M: tuple pprint-delims drop \ T{ \ } ;
 147 M: wrapper pprint-delims drop \ W{ \ } ;
 148 M: callstack pprint-delims drop \ CS{ \ } ;
 149
 150 GENERIC: >pprint-sequence ( obj -- seq )
 151
 152 M: object >pprint-sequence ;
 153
 154 M: vector >pprint-sequence ;
 155 M: bit-vector >pprint-sequence ;
 156 M: byte-vector >pprint-sequence ;
 157 M: float-vector >pprint-sequence ;
 158 M: curry >pprint-sequence ;
 159 M: compose >pprint-sequence ;
 160 M: hashtable >pprint-sequence >alist ;
 161 M: tuple >pprint-sequence tuple>array ;
 162 M: wrapper >pprint-sequence wrapped 1array ;
 163 M: callstack >pprint-sequence callstack>array ;
 164
 165 GENERIC: pprint-narrow? ( obj -- ? )
 166
 167 M: object pprint-narrow? drop f ;
 168
 169 M: array pprint-narrow? drop t ;
 170 M: vector pprint-narrow? drop t ;
 171 M: hashtable pprint-narrow? drop t ;
 172 M: tuple pprint-narrow? drop t ;
 173
 174 : pprint-object ( obj -- )
 175     [
 176         <flow
 177         dup pprint-delims >r pprint-word
 178         dup pprint-narrow? <inset
 179         >pprint-sequence pprint-elements
 180         block> r> pprint-word block>
 181     ] check-recursion ;
 182
 183 M: object pprint* pprint-object ;
 184
 185 M: curry pprint*
 186     dup curry-quot callable? [ pprint-object ] [
 187         "( invalid curry )" swap present-text
 188     ] if ;
 189
 190 M: compose pprint*
 191     dup compose-first over compose-second [ callable? ] both?
 192     [ pprint-object ] [
 193         "( invalid compose )" swap present-text
 194     ] if ;
 195
 196 M: wrapper pprint*
 197     dup wrapped word? [
 198         <block \ \ pprint-word wrapped pprint-word block>
 199     ] [
 200         pprint-object
 201     ] if ;
 202
 203 M: tuple-layout pprint*
 204     "( tuple layout )" swap present-text ;