library/prettyprint.factor

   1 ! :folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2003, 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: prettyprint
  29 USE: arithmetic
  30 USE: combinators
  31 USE: errors
  32 USE: format
  33 USE: kernel
  34 USE: logic
  35 USE: lists
  36 USE: namespaces
  37 USE: prettyprint
  38 USE: stack
  39 USE: stdio
  40 USE: strings
  41 USE: styles
  42 USE: unparser
  43 USE: vectors
  44 USE: vocabularies
  45 USE: words
  46
  47 : tab-size
  48     #! Change this to suit your tastes.
  49     4 ;
  50
  51 : prettyprint-indent ( indent -- )
  52     #! Print the given number of spaces.
  53     " " fill write ;
  54
  55 : prettyprint-newline ( indent -- )
  56     "\n" write prettyprint-indent ;
  57
  58 : prettyprint-space ( -- )
  59     " " write ;
  60
  61 : newline-after? ( obj -- ? )
  62     comment? ;
  63
  64 ! Real definition follows
  65 DEFER: prettyprint*
  66
  67 : prettyprint-element ( indent obj -- indent )
  68     dup >r prettyprint* r> newline-after? [
  69         dup prettyprint-newline
  70     ] [
  71         prettyprint-space
  72     ] ifte ;
  73
  74 : <prettyprint ( indent -- indent )
  75     tab-size +
  76     "prettyprint-single-line" get [
  77         prettyprint-space
  78     ] [
  79         dup prettyprint-newline
  80     ] ifte ;
  81
  82 : prettyprint> ( indent -- indent )
  83     tab-size -
  84     "prettyprint-single-line" get [
  85         dup prettyprint-newline
  86     ] unless ;
  87
  88 : prettyprint-[ ( indent -- indent )
  89     "[" write <prettyprint ;
  90
  91 : prettyprint-] ( indent -- indent )
  92     prettyprint> "]" write ;
  93
  94 : prettyprint-list ( indent list -- indent )
  95     #! Pretty-print a list, without [ and ].
  96     [ prettyprint-element ] each ;
  97
  98 : prettyprint-[] ( indent list -- indent )
  99     swap prettyprint-[ swap prettyprint-list prettyprint-] ;
 100
 101 : prettyprint-{ ( indent -- indent )
 102     "{" write <prettyprint ;
 103
 104 : prettyprint-} ( indent -- indent )
 105     prettyprint> "}" write ;
 106
 107 : prettyprint-vector ( indent list -- indent )
 108     #! Pretty-print a vector, without { and }.
 109     [ prettyprint-element ] vector-each ;
 110
 111 : prettyprint-{} ( indent list -- indent )
 112     swap prettyprint-{ swap prettyprint-vector prettyprint-} ;
 113
 114 : trim-newline ( str -- str )
 115     dup ends-with-newline? dup [ nip ] [ drop ] ifte ;
 116
 117 : prettyprint-comment ( comment -- )
 118     [ "comments" ] get-style [ trim-newline write-attr ] bind ;
 119
 120 : word-link ( word -- link )
 121     <%
 122     "vocabularies'" %
 123     dup word-vocabulary %
 124     "'" %
 125     word-name %
 126     %> ;
 127
 128 : word-attrs ( word -- attrs )
 129     dup word-style clone swap
 130     dup defined? [
 131         swap [ word-link "link" set ] extend
 132     ] [
 133         drop
 134     ] ifte ;
 135
 136 : prettyprint-word ( word -- )
 137     dup word-attrs [ word-name write-attr ] bind ;
 138
 139 : prettyprint-object ( indent obj -- indent )
 140     unparse write ;
 141
 142 : prettyprint* ( indent obj -- indent )
 143     [
 144         [ f =       ] [ prettyprint-object ]
 145         [ list?     ] [ prettyprint-[] ]
 146         [ vector?   ] [ prettyprint-{} ]
 147         [ comment?  ] [ prettyprint-comment ]
 148         [ word?     ] [ prettyprint-word ]
 149         [ drop t    ] [ prettyprint-object ]
 150     ] cond ;
 151
 152 : prettyprint ( obj -- )
 153     0 swap prettyprint* drop terpri ;
 154
 155 : prettyprint-: ( indent -- indent )
 156     ":" write prettyprint-space
 157     tab-size + ;
 158
 159 : prettyprint-; ( indent -- indent )
 160     ";" write
 161     tab-size - ;
 162
 163 : prettyprint-:; ( indent word list -- indent )
 164     >r
 165     >r prettyprint-: r>
 166     prettyprint-word prettyprint-space r>
 167     prettyprint-list prettyprint-; ;
 168
 169 : . ( obj -- )
 170     <namespace> [
 171         "prettyprint-single-line" on prettyprint
 172     ] bind ;
 173
 174 : [.] ( list -- )
 175     #! Unparse each element on its own line.
 176     [ . ] each ;
 177
 178 : .n namestack  . ;
 179 : .s datastack  . ;
 180 : .r callstack  . ;
 181 : .c catchstack . ;