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