basis/prettyprint/sections/sections.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays generic hashtables io kernel math assocs
   4 namespaces sequences strings io.styles vectors words
   5 prettyprint.config splitting classes continuations
   6 io.streams.nested accessors sets ;
   7 IN: prettyprint.sections
   8
   9 ! State
  10 SYMBOL: position
  11 SYMBOL: recursion-check
  12 SYMBOL: pprinter-stack
  13
  14 ! We record vocabs of all words
  15 SYMBOL: pprinter-in
  16 SYMBOL: pprinter-use
  17
  18 TUPLE: pprinter last-newline line-count indent ;
  19
  20 : <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
  21
  22 : record-vocab ( word -- )
  23     vocabulary>> [ pprinter-use get conjoin ] when* ;
  24
  25 ! Utility words
  26 : line-limit? ( -- ? )
  27     line-limit get dup [ pprinter get line-count>> <= ] when ;
  28
  29 : do-indent ( -- ) pprinter get indent>> CHAR: \s <string> write ;
  30
  31 : fresh-line ( n -- )
  32     dup pprinter get last-newline>> = [
  33         drop
  34     ] [
  35         pprinter get (>>last-newline)
  36         line-limit? [
  37             "..." write pprinter get return
  38         ] when
  39         pprinter get [ 1+ ] change-line-count drop
  40         nl do-indent
  41     ] if ;
  42
  43 : text-fits? ( len -- ? )
  44     margin get dup zero?
  45     [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
  46
  47 ! break only if position margin 2 / >
  48 SYMBOL: soft
  49
  50 ! always breaks
  51 SYMBOL: hard
  52
  53 ! Section protocol
  54 GENERIC: section-fits? ( section -- ? )
  55
  56 GENERIC: short-section ( section -- )
  57
  58 GENERIC: long-section ( section -- )
  59
  60 GENERIC: indent-section? ( section -- ? )
  61
  62 GENERIC: unindent-first-line? ( section -- ? )
  63
  64 GENERIC: newline-after? ( section -- ? )
  65
  66 GENERIC: short-section? ( section -- ? )
  67
  68 ! Sections
  69 TUPLE: section
  70 start end
  71 start-group? end-group?
  72 style overhang ;
  73
  74 : new-section ( length class -- section )
  75     new
  76         position get >>start
  77         swap position [ + ] change
  78         position get >>end
  79         0 >>overhang ; inline
  80
  81 M: section section-fits? ( section -- ? )
  82     [ end>> pprinter get last-newline>> - ]
  83     [ overhang>> ] bi
  84     + text-fits? ;
  85
  86 M: section indent-section? drop f ;
  87
  88 M: section unindent-first-line? drop f ;
  89
  90 M: section newline-after? drop f ;
  91
  92 M: object short-section? section-fits? ;
  93
  94 : indent+ ( section n -- )
  95     swap indent-section? [
  96         pprinter get [ + ] change-indent drop
  97     ] [ drop ] if ;
  98
  99 : <indent ( section -- ) tab-size get indent+ ;
 100
 101 : indent> ( section -- ) tab-size get neg indent+ ;
 102
 103 : <fresh-line ( section -- )
 104     start>> fresh-line ;
 105
 106 : fresh-line> ( section -- )
 107     dup newline-after? [ end>> fresh-line ] [ drop ] if ;
 108
 109 : <long-section ( section -- )
 110     dup unindent-first-line?
 111     [ dup <fresh-line <indent ] [ dup <indent <fresh-line ] if ;
 112
 113 : long-section> ( section -- )
 114     dup indent> fresh-line> ;
 115
 116 : pprint-section ( section -- )
 117     dup short-section? [
 118         dup section-style [ short-section ] with-style
 119     ] [
 120         [ <long-section ]
 121         [ dup section-style [ long-section ] with-style ]
 122         [ long-section> ]
 123         tri
 124     ] if ;
 125
 126 ! Break section
 127 TUPLE: line-break < section type ;
 128
 129 : <line-break> ( type -- section )
 130     0 \ line-break new-section
 131         swap >>type ;
 132
 133 M: line-break short-section drop ;
 134
 135 M: line-break long-section drop ;
 136
 137 ! Block sections
 138 TUPLE: block < section sections ;
 139
 140 : new-block ( style class -- block )
 141     0 swap new-section
 142         V{ } clone >>sections
 143         swap >>style ; inline
 144
 145 : <block> ( style -- block )
 146     block new-block ;
 147
 148 : pprinter-block ( -- block ) pprinter-stack get peek ;
 149
 150 : add-section ( section -- )
 151     pprinter-block sections>> push ;
 152
 153 : last-section ( -- section )
 154     pprinter-block sections>>
 155     [ line-break? not ] find-last nip ;
 156
 157 : start-group ( -- )
 158     last-section t >>start-group? drop ;
 159
 160 : end-group ( -- )
 161     last-section t >>end-group? drop ;
 162
 163 : advance ( section -- )
 164     [ start>> pprinter get last-newline>> = not ]
 165     [ short-section? ] bi
 166     and [ bl ] when ;
 167
 168 : line-break ( type -- ) [ <line-break> add-section ] when* ;
 169
 170 M: block section-fits? ( section -- ? )
 171     line-limit? [ drop t ] [ call-next-method ] if ;
 172
 173 : pprint-sections ( block advancer -- )
 174     swap sections>> [ line-break? not ] filter
 175     unclip pprint-section [
 176         dup rot call pprint-section
 177     ] with each ; inline
 178
 179 M: block short-section ( block -- )
 180     [ advance ] pprint-sections ;
 181
 182 : do-break ( break -- )
 183     [ ]
 184     [ type>> hard eq? ]
 185     [ end>> pprinter get last-newline>> - margin get 2/ > ] tri
 186     or [ <fresh-line ] [ drop ] if ;
 187
 188 : empty-block? ( block -- ? ) sections>> empty? ;
 189
 190 : if-nonempty ( block quot -- )
 191     >r dup empty-block? [ drop ] r> if ; inline
 192
 193 : (<block) ( block -- ) pprinter-stack get push ;
 194
 195 : <block ( -- ) f <block> (<block) ;
 196
 197 : <object ( obj -- ) presented associate <block> (<block) ;
 198
 199 ! Text section
 200 TUPLE: text < section string ;
 201
 202 : <text> ( string style -- text )
 203     over length 1+ \ text new-section
 204         swap >>style
 205         swap >>string ;
 206
 207 M: text short-section text-string write ;
 208
 209 M: text long-section short-section ;
 210
 211 : styled-text ( string style -- ) <text> add-section ;
 212
 213 : text ( string -- ) H{ } styled-text ;
 214
 215 ! Inset section
 216 TUPLE: inset < block narrow? ;
 217
 218 : <inset> ( narrow? -- block )
 219     H{ } inset new-block
 220         2 >>overhang
 221         swap >>narrow? ;
 222
 223 M: inset long-section
 224     dup narrow?>> [
 225         [ <fresh-line ] pprint-sections
 226     ] [
 227         call-next-method
 228     ] if ;
 229
 230 M: inset indent-section? drop t ;
 231
 232 M: inset newline-after? drop t ;
 233
 234 : <inset ( narrow? -- ) <inset> (<block) ;
 235
 236 ! Flow section
 237 TUPLE: flow < block ;
 238
 239 : <flow> ( -- block )
 240     H{ } flow new-block ;
 241
 242 M: flow short-section? ( section -- ? )
 243     #! If we can make room for this entire block by inserting
 244     #! a newline, do it; otherwise, don't bother, print it as
 245     #! a short section
 246     [ section-fits? ]
 247     [ [ end>> ] [ start>> ] bi - text-fits? not ] bi
 248     or ;
 249
 250 : <flow ( -- ) <flow> (<block) ;
 251
 252 ! Colon definition section
 253 TUPLE: colon < block ;
 254
 255 : <colon> ( -- block )
 256     H{ } colon new-block ;
 257
 258 M: colon long-section short-section ;
 259
 260 M: colon indent-section? drop t ;
 261
 262 M: colon unindent-first-line? drop t ;
 263
 264 : <colon ( -- ) <colon> (<block) ;
 265
 266 : save-end-position ( block -- )
 267     position get >>end drop ;
 268
 269 : block> ( -- )
 270     pprinter-stack get pop
 271     [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
 272
 273 : do-pprint ( block -- )
 274     <pprinter> pprinter [
 275         [
 276             dup style>> [
 277                 [
 278                     short-section
 279                 ] curry with-return
 280             ] with-nesting
 281         ] if-nonempty
 282     ] with-variable ;
 283
 284 ! Long section layout algorithm
 285 : chop-break ( seq -- seq )
 286     dup peek line-break? [ but-last-slice chop-break ] when ;
 287
 288 SYMBOL: prev
 289 SYMBOL: next
 290
 291 : split-groups ( ? -- ) [ t , ] when ;
 292
 293 M: f section-start-group? drop t ;
 294
 295 M: f section-end-group? drop f ;
 296
 297 : split-before ( section -- )
 298     [ section-start-group? prev get section-end-group? and ]
 299     [ flow? prev get flow? not and ]
 300     bi or split-groups ;
 301
 302 : split-after ( section -- )
 303     section-end-group? split-groups ;
 304
 305 : group-flow ( seq -- newseq )
 306     [
 307         dup length [
 308             2dup 1- swap ?nth prev set
 309             2dup 1+ swap ?nth next set
 310             swap nth dup split-before dup , split-after
 311         ] with each
 312     ] { } make { t } split harvest ;
 313
 314 : break-group? ( seq -- ? )
 315     [ first section-fits? ] [ peek section-fits? not ] bi and ;
 316
 317 : ?break-group ( seq -- )
 318     dup break-group? [ first <fresh-line ] [ drop ] if ;
 319
 320 M: block long-section ( block -- )
 321     [
 322         sections>> chop-break group-flow [
 323             dup ?break-group [
 324                 dup line-break? [
 325                     do-break
 326                 ] [
 327                     [ advance ] [ pprint-section ] bi
 328                 ] if
 329             ] each
 330         ] each
 331     ] if-nonempty ;