basis/prettyprint/sections/sections.factor

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