basis/prettyprint/sections/sections.factor

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