basis/prettyprint/backend/backend.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays byte-arrays byte-vectors generic
   4 hashtables io assocs kernel math namespaces make sequences
   5 strings sbufs io.styles vectors words prettyprint.config
   6 prettyprint.sections quotations io io.files math.parser effects
   7 classes.tuple math.order classes.tuple.private classes
   8 combinators colors ;
   9 IN: prettyprint.backend
  10
  11 GENERIC: pprint* ( obj -- )
  12
  13 M: effect pprint* effect>string "(" swap ")" 3append 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 \ >r hard "break-before" set-word-prop
  25 \ r> hard "break-after" set-word-prop
  26
  27 ! Atoms
  28 : word-style ( word -- style )
  29     dup "word-style" word-prop >hashtable [
  30         [
  31             [ presented set ]
  32             [
  33                 [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
  34                 [ bold font-style set ] when
  35             ] bi
  36         ] bind
  37     ] keep ;
  38
  39 : word-name* ( word -- str )
  40     name>> "( no name )" or ;
  41
  42 : pprint-word ( word -- )
  43     dup record-vocab
  44     dup word-name* swap word-style styled-text ;
  45
  46 : pprint-prefix ( word quot -- )
  47     <block swap pprint-word call block> ; inline
  48
  49 M: word pprint*
  50     dup parsing-word? [
  51         \ POSTPONE: [ pprint-word ] pprint-prefix
  52     ] [
  53         {
  54             [ "break-before" word-prop line-break ]
  55             [ pprint-word ]
  56             [ ?start-group ]
  57             [ ?end-group ]
  58             [ "break-after" word-prop line-break ]
  59         } cleave
  60     ] if ;
  61
  62 M: real pprint* number>string text ;
  63
  64 M: f pprint* drop \ f pprint-word ;
  65
  66 ! Strings
  67 : ch>ascii-escape ( ch -- str )
  68     H{
  69         { CHAR: \a CHAR: a  }
  70         { CHAR: \e CHAR: e  }
  71         { CHAR: \n CHAR: n  }
  72         { CHAR: \r CHAR: r  }
  73         { CHAR: \t CHAR: t  }
  74         { CHAR: \0 CHAR: 0  }
  75         { CHAR: \\ CHAR: \\ }
  76         { CHAR: \" CHAR: \" }
  77     } at ;
  78
  79 : unparse-ch ( ch -- )
  80     dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
  81
  82 : do-string-limit ( str -- trimmed )
  83     string-limit? get [
  84         dup length margin get > [
  85             margin get 3 - head "..." append
  86         ] when
  87     ] when ;
  88
  89 : string-style ( obj -- hash )
  90     [
  91         presented set
  92         T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
  93     ] H{ } make-assoc ;
  94
  95 : unparse-string ( str prefix suffix -- str )
  96     [ >r % do-string-limit [ unparse-ch ] each r> % ] "" 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         "~" over class name>> "~" 3append
 121         swap present-text
 122     ] [
 123         over recursion-check get memq? [
 124             drop "~circularity~" swap present-text
 125         ] [
 126             over recursion-check get push
 127             call
 128             recursion-check get pop*
 129         ] if
 130     ] if ; inline
 131
 132 : tuple>assoc ( tuple -- assoc )
 133     [ class all-slots ] [ tuple-slots ] bi zip
 134     [ [ initial>> ] dip = not ] assoc-filter
 135     [ [ name>> ] dip ] assoc-map ;
 136
 137 : pprint-slot-value ( name value -- )
 138     <flow \ { pprint-word
 139     [ text ] [ f <inset pprint* block> ] bi*
 140     \ } pprint-word block> ;
 141
 142 M: tuple pprint*
 143     boa-tuples? get [ call-next-method ] [
 144         [
 145             <flow
 146             \ T{ pprint-word
 147             dup class pprint-word
 148             t <inset
 149             tuple>assoc [ pprint-slot-value ] assoc-each
 150             block>
 151             \ } pprint-word
 152             block>
 153         ] check-recursion
 154     ] if ;
 155
 156 : do-length-limit ( seq -- trimmed n/f )
 157     length-limit get dup [
 158         over length over [-]
 159         dup zero? [ 2drop f ] [ >r head r> ] if
 160     ] when ;
 161
 162 : pprint-elements ( seq -- )
 163     do-length-limit >r
 164     [ pprint* ] each
 165     r> [ "~" swap number>string " more~" 3append text ] when* ;
 166
 167 GENERIC: pprint-delims ( obj -- start end )
 168
 169 M: quotation pprint-delims drop \ [ \ ] ;
 170 M: curry pprint-delims drop \ [ \ ] ;
 171 M: compose pprint-delims drop \ [ \ ] ;
 172 M: array pprint-delims drop \ { \ } ;
 173 M: byte-array pprint-delims drop \ B{ \ } ;
 174 M: byte-vector pprint-delims drop \ BV{ \ } ;
 175 M: vector pprint-delims drop \ V{ \ } ;
 176 M: hashtable pprint-delims drop \ H{ \ } ;
 177 M: tuple pprint-delims drop \ T{ \ } ;
 178 M: wrapper pprint-delims drop \ W{ \ } ;
 179 M: callstack pprint-delims drop \ CS{ \ } ;
 180
 181 GENERIC: >pprint-sequence ( obj -- seq )
 182
 183 M: object >pprint-sequence ;
 184
 185 M: vector >pprint-sequence ;
 186 M: byte-vector >pprint-sequence ;
 187 M: curry >pprint-sequence ;
 188 M: compose >pprint-sequence ;
 189 M: hashtable >pprint-sequence >alist ;
 190 M: wrapper >pprint-sequence wrapped>> 1array ;
 191 M: callstack >pprint-sequence callstack>array ;
 192
 193 M: tuple >pprint-sequence
 194     [ class ] [ tuple-slots ] bi
 195     [ 1array ] [ [ f 2array ] dip append ] if-empty ;
 196
 197 GENERIC: pprint-narrow? ( obj -- ? )
 198
 199 M: object pprint-narrow? drop f ;
 200
 201 M: array pprint-narrow? drop t ;
 202 M: vector pprint-narrow? drop t ;
 203 M: hashtable pprint-narrow? drop t ;
 204 M: tuple pprint-narrow? drop t ;
 205
 206 : pprint-object ( obj -- )
 207     [
 208         <flow
 209         dup pprint-delims >r pprint-word
 210         dup pprint-narrow? <inset
 211         >pprint-sequence pprint-elements
 212         block> r> pprint-word block>
 213     ] check-recursion ;
 214
 215 M: object pprint* pprint-object ;
 216 M: vector pprint* pprint-object ;
 217 M: hashtable pprint* pprint-object ;
 218
 219 M: curry pprint*
 220     dup quot>> callable? [ pprint-object ] [
 221         "( invalid curry )" swap present-text
 222     ] if ;
 223
 224 M: compose pprint*
 225     dup [ first>> callable? ] [ second>> callable? ] bi and
 226     [ pprint-object ] [
 227         "( invalid compose )" swap present-text
 228     ] if ;
 229
 230 M: wrapper pprint*
 231     dup wrapped>> word? [
 232         <block \ \ pprint-word wrapped>> pprint-word block>
 233     ] [
 234         pprint-object
 235     ] if ;
 236
 237 M: tuple-layout pprint*
 238     "( tuple layout )" swap present-text ;