basis/prettyprint/sections/sections.factor

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