core/prettyprint/sections.factor

   1 ! Copyright (C) 2003, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: prettyprint-internals
   4 USING: alien arrays generic hashtables io kernel math
   5 namespaces parser sequences strings styles vectors words
   6 prettyprint ;
   7
   8 ! Sections
   9 TUPLE: section start end style ;
  10
  11 C: section ( style length -- section )
  12     >r position [ dup rot + dup ] change r>
  13     [ set-section-end ] keep
  14     [ set-section-start ] keep
  15     [ set-section-style ] keep ;
  16
  17 GENERIC: section-fits? ( section -- ? )
  18
  19 M: section section-fits? ( section -- ? )
  20     section-end last-newline get - text-fits? ;
  21
  22 GENERIC: short-section ( section -- )
  23
  24 GENERIC: long-section ( section -- )
  25
  26 GENERIC: block-empty? ( section -- ? )
  27
  28 : pprint-section ( section -- )
  29     {
  30         { [ margin get zero? ] [ short-section ] }
  31         { [ dup section-fits? ] [ short-section ] }
  32         { [ t ] [ long-section ] }
  33     } cond ;
  34
  35 ! Block sections
  36 TUPLE: block sections ;
  37
  38 C: block ( style -- block )
  39     swap 0 <section> over set-delegate
  40     V{ } clone over set-block-sections ;
  41
  42 : pprinter-block ( -- block ) pprinter-stack get peek ;
  43
  44 : add-section ( section -- )
  45     dup block-empty?
  46     [ drop ] [ pprinter-block block-sections push ] if ;
  47
  48 M: block block-empty? block-sections empty? ;
  49
  50 M: block section-fits? ( section -- ? )
  51     line-limit? [
  52         drop t
  53     ] [
  54         delegate section-fits?
  55     ] if ;
  56
  57 : (<block) pprinter-stack get push ;
  58
  59 : <style section-style stdio [ <nested-style-stream> ] change ;
  60
  61 : style> stdio [ delegate ] change ;
  62
  63 : change-indent ( n -- )
  64     tab-size get * indent [ + ] change ;
  65
  66 : <indent ( -- ) 1 change-indent ;
  67
  68 : indent> ( -- ) -1 change-indent ;
  69
  70 ! Text section
  71 TUPLE: text string ;
  72
  73 C: text ( string style -- text )
  74     [ >r over length 1+ <section> r> set-delegate ] keep
  75     [ set-text-string ] keep ;
  76
  77 M: text block-empty? drop f ;
  78
  79 M: text short-section
  80     dup text-string swap section-style format ;
  81
  82 M: text long-section
  83     dup section-start fresh-line short-section ;
  84
  85 : styled-text ( string style -- ) <text> add-section ;
  86
  87 : text ( string -- ) H{ } styled-text ;
  88
  89 ! Newline section
  90 TUPLE: newline ;
  91
  92 C: newline ( -- section )
  93     H{ } 0 <section> over set-delegate ;
  94
  95 M: newline block-empty? drop f ;
  96
  97 M: newline section-fits? drop t ;
  98
  99 M: newline short-section section-start fresh-line ;
 100
 101 : newline ( -- ) <newline> add-section ;
 102
 103 ! Inset section
 104 TUPLE: inset ;
 105
 106 C: inset ( style -- block )
 107     swap <block> over set-delegate ;
 108
 109 M: inset section-fits? ( section -- ? )
 110     line-limit? [
 111         drop t
 112     ] [
 113         section-end last-newline get - 2 + text-fits?
 114     ] if ;
 115
 116 : advance ( section -- )
 117     dup newline? [
 118         drop
 119     ] [
 120         section-start last-newline get = [ bl ] unless
 121     ] if ;
 122
 123 M: block short-section ( block -- )
 124     dup <style
 125     block-sections unclip pprint-section
 126     [ dup advance pprint-section ] each
 127     style> ;
 128
 129 M: inset long-section
 130     <indent
 131     dup section-start fresh-line dup short-section
 132     indent>
 133     section-end fresh-line ;
 134
 135 : <inset ( style -- ) <inset> (<block) ;
 136
 137 ! Flow section
 138 TUPLE: flow ;
 139
 140 C: flow ( style -- block )
 141     swap <block> over set-delegate ;
 142
 143 M: flow section-fits? ( section -- ? )
 144     dup delegate section-fits? [
 145         drop t
 146     ] [
 147         dup section-end swap section-start - text-fits? not
 148     ] if ;
 149
 150 M: flow long-section
 151     dup section-start fresh-line short-section ;
 152
 153 : <flow ( style -- ) <flow> (<block) ;
 154
 155 ! Narrow section
 156 TUPLE: narrow ;
 157
 158 C: narrow ( style -- block )
 159     swap <block> over set-delegate ;
 160
 161 M: narrow section-fits? ( section -- ? )
 162     line-limit? [
 163         drop t
 164     ] [
 165         section-end last-newline get - 2 + text-fits?
 166     ] if ;
 167
 168 : narrow-block ( block -- )
 169     dup <style
 170     block-sections unclip pprint-section
 171     [ dup section-start fresh-line pprint-section ] each
 172     style> ;
 173
 174 M: narrow long-section
 175     <indent
 176     dup section-start fresh-line dup narrow-block
 177     indent>
 178     section-end fresh-line ;
 179
 180 : <narrow ( style -- ) <narrow> (<block) ;
 181
 182 ! Defblock section
 183 TUPLE: defblock ;
 184
 185 C: defblock ( style -- block )
 186     swap <block> over set-delegate ;
 187
 188 M: defblock long-section
 189     <indent
 190     dup section-start fresh-line short-section
 191     indent> ;
 192
 193 : <defblock ( style -- ) <defblock> (<block) ;
 194
 195 : end-block ( block -- ) position get swap set-section-end ;
 196
 197 : (block>) ( -- )
 198     pprinter-stack get pop dup end-block add-section ;
 199
 200 : last-block? ( -- ? ) pprinter-stack get length 1 = ;
 201
 202 : block> ( -- ) last-block? [ (block>) ] unless ;
 203
 204 : end-blocks ( -- ) last-block? [ (block>) end-blocks ] unless ;
 205
 206 : do-pprint ( -- )
 207     [
 208         end-printing set pprinter-block
 209         dup block-empty? [ drop ] [ pprint-section ] if
 210     ] callcc0 ;