basis/prettyprint/sections/sections.factor

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