basis/ui/gadgets/panes/panes.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes combinators destructors
   4 documents.private fonts io io.styles kernel math math.rectangles
   5 math.vectors models namespaces sequences sets sorting splitting
   6 strings ui.baseline-alignment ui.clipboards ui.gadgets
   7 ui.gadgets.borders ui.gadgets.grid-lines ui.gadgets.grids
   8 ui.gadgets.icons ui.gadgets.incremental ui.gadgets.labels
   9 ui.gadgets.menus ui.gadgets.packs ui.gadgets.paragraphs
  10 ui.gadgets.presentations ui.gadgets.private ui.gadgets.scrollers
  11 ui.gadgets.tracks ui.gestures ui.images ui.pens.solid ui.render
  12 ui.theme ui.traverse unicode ;
  13 FROM: io.styles => foreground background ;
  14 FROM: ui.gadgets.wrappers => <wrapper> ;
  15 IN: ui.gadgets.panes
  16
  17 TUPLE: pane < track
  18     output current input last-line prototype scrolls?
  19     selection-color caret mark selecting? ;
  20
  21 TUPLE: pane-stream pane parent ;
  22 INSTANCE: pane-stream output-stream
  23
  24 : <pane-stream> ( pane -- pane-stream )
  25     f pane-stream boa ;
  26
  27 M: pane-stream stream-element-type drop +character+ ;
  28
  29 DEFER: write-gadget
  30
  31 <PRIVATE
  32
  33 : clear-selection ( pane -- pane )
  34     f >>caret f >>mark ; inline
  35
  36 : prepare-last-line ( pane -- )
  37     [ last-line>> ] keep
  38     [ current>> f track-add ]
  39     [ input>> [ 1 track-add ] when* ] bi
  40     drop ; inline
  41
  42 : init-current ( pane -- pane )
  43     dup prototype>> clone >>current ; inline
  44
  45 : focus-input ( pane -- )
  46     input>> [ request-focus ] when* ;
  47
  48 : next-line ( pane -- )
  49     [ input>> unparent ]
  50     [ init-current prepare-last-line ]
  51     [ focus-input ] tri ;
  52
  53 : pane-caret&mark ( pane -- caret mark )
  54     [ caret>> ] [ mark>> ] bi ; inline
  55
  56 : selected-subtree ( pane -- seq )
  57     [ pane-caret&mark sort-pair ] keep gadget-subtree ;
  58
  59 M: pane gadget-selection? pane-caret&mark and ;
  60
  61 M: pane gadget-selection selected-subtree gadget-text ;
  62
  63 : init-prototype ( pane -- pane )
  64     <shelf> +baseline+ >>align >>prototype ; inline
  65
  66 : init-output ( pane -- pane )
  67     <incremental> [ >>output ] [ f track-add ] bi ; inline
  68
  69 : pane-theme ( pane -- pane )
  70     1 >>fill
  71     selection-color >>selection-color ; inline
  72
  73 : init-last-line ( pane -- pane )
  74     horizontal <track> 0 >>fill +baseline+ >>align
  75     [ >>last-line ] [ 1 track-add ] bi
  76     dup prepare-last-line ; inline
  77
  78 M: pane selected-children
  79     dup gadget-selection? [
  80         [ selected-subtree leaves ]
  81         [ selection-color>> ]
  82         bi
  83     ] [ drop f f ] if ;
  84
  85 : scroll-pane ( pane -- )
  86     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
  87
  88 GENERIC: pane-label ( pane -- label )
  89
  90 M: pane pane-label drop "" <label> ;
  91
  92 : smash-line ( pane current -- gadget )
  93     dup children>> {
  94         { [ dup empty? ] [ 2drop pane-label ] }
  95         { [ dup length 1 = ] [ 2nip first ] }
  96         [ drop nip ]
  97     } cond ;
  98
  99 : pane-nl ( pane -- )
 100     [
 101         [ dup current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
 102         add-incremental
 103     ] [ next-line ] bi ;
 104
 105 GENERIC: smash-pane ( pane -- gadget )
 106
 107 M: pane smash-pane
 108     [ pane-nl ] [ dup output>> smash-line ] bi ;
 109
 110 GENERIC: pane-line ( str style gadget -- )
 111
 112 : pane-format ( lines style pane -- )
 113     [ nip pane-nl ] [ current>> pane-line ]
 114     bi-curry bi-curry interleave ;
 115
 116 : pane-write ( lines pane -- )
 117     H{ } swap pane-format ;
 118
 119 : pane-write1 ( char pane -- )
 120     [ 1string H{ } ] dip current>> pane-line ;
 121
 122 :: do-pane-stream ( pane-stream quot -- )
 123     pane-stream pane>> :> pane
 124     pane find-scroller :> scroller
 125     scroller [
 126         model>> {
 127             [ range-value second ]
 128             [ range-page-value second + ]
 129             [ range-max-value second >= ]
 130         } cleave
 131     ] [ f ] if* :> bottom?
 132     pane quot call
 133     pane scrolls?>> bottom? and scroller and [
 134         scroller {
 135             [ model>> range-value first ]
 136             [ model>> range-max-value second 2array ]
 137             [ set-scroll-position ]
 138         } cleave
 139     ] when ; inline
 140
 141 M: pane-stream stream-nl
 142     [ pane-nl ] do-pane-stream ;
 143
 144 M: pane-stream stream-write1
 145     [ pane-write1 ] do-pane-stream ;
 146
 147 : split-pane ( str quot: ( str -- ) -- )
 148     '[
 149         dup length 3639 >
 150         [ 3639 over last-grapheme-from cut-slice ] [ f ] if
 151         swap "" like ?split-lines @ dup
 152     ] loop drop ; inline
 153
 154 M: pane-stream stream-write
 155     [ '[ _ pane-write ] split-pane ] do-pane-stream ;
 156
 157 M: pane-stream stream-format
 158     [ '[ _ _ pane-format ] split-pane ] do-pane-stream ;
 159
 160 M: pane-stream dispose
 161     dup parent>> [
 162         [ pane>> smash-pane ] dip write-gadget
 163     ] [ drop ] if* ;
 164
 165 ! M: pane-stream dispose drop ;
 166
 167 M: pane-stream stream-flush drop ;
 168
 169 M: pane-stream make-span-stream
 170     swap <style-stream> <ignore-close-stream> ;
 171
 172 PRIVATE>
 173
 174 : new-pane ( input class -- pane )
 175     [ vertical ] dip new-track
 176         swap >>input
 177         pane-theme
 178         init-prototype
 179         init-output
 180         init-current
 181         init-last-line ; inline
 182
 183 : <pane> ( -- pane ) f pane new-pane ;
 184
 185 GENERIC: gadget-alt-text ( gadget -- string )
 186
 187 M: object gadget-alt-text
 188     class-of name>> "( " " )" surround ;
 189
 190 GENERIC: write-gadget ( gadget stream -- )
 191
 192 M: object write-gadget
 193     [ gadget-alt-text ] dip stream-write ;
 194
 195 M: filter-writer write-gadget
 196     stream>> write-gadget ;
 197
 198 M: pane-stream write-gadget
 199     [ current>> swap add-gadget drop ] do-pane-stream ;
 200
 201 : print-gadget ( gadget stream -- )
 202     [ write-gadget ] [ nip stream-nl ] 2bi ;
 203
 204 : gadget. ( gadget -- )
 205     output-stream get print-gadget ;
 206
 207 : clear-pane ( pane -- )
 208     clear-selection
 209     [ output>> clear-incremental ]
 210     [ current>> clear-gadget ]
 211     bi ;
 212
 213 : with-pane ( pane quot -- )
 214     over [
 215         [ [ scroll>top ] [ clear-pane ] [ <pane-stream> ] tri ] dip
 216         with-output-stream*
 217     ] dip scroll-pane ; inline
 218
 219 : make-pane ( quot -- gadget )
 220     [ <pane> ] dip '[ _ with-pane ] keep smash-pane ; inline
 221
 222 TUPLE: pane-control < pane quot ;
 223
 224 M: pane-control model-changed
 225     [ value>> ] [ dup quot>> ] bi*
 226     '[ _ call( value -- ) ] with-pane ;
 227
 228 : <pane-control> ( model quot -- pane )
 229     f pane-control new-pane
 230         swap >>quot
 231         swap >>model ;
 232
 233 <PRIVATE
 234
 235 ! Character styles
 236
 237 MEMO:: specified-font ( name style size foreground background -- font )
 238     ! We memoize here to avoid creating lots of duplicate font objects.
 239     monospace-font
 240         name [ >>name ] when*
 241         style {
 242             { f [ ] }
 243             { plain [ ] }
 244             { bold [ t >>bold? ] }
 245             { italic [ t >>italic? ] }
 246             { bold-italic [ t >>bold? t >>italic? ] }
 247         } case
 248         size [ >>size ] when*
 249         foreground [ >>foreground ] when*
 250         background [ >>background ] when* ;
 251
 252 : apply-font-style ( style gadget -- style gadget )
 253     over {
 254         [ font-name of ]
 255         [ font-style of ]
 256         [ font-size of ]
 257         [ foreground of ]
 258         [ background of ]
 259     } cleave specified-font >>font ;
 260
 261 : apply-style ( style gadget key quot -- style gadget )
 262     [ pick at ] dip when* ; inline
 263
 264 : apply-presentation-style ( style gadget -- style gadget )
 265     presented [ <presentation> ] apply-style ;
 266
 267 : apply-image-style ( style gadget -- style gadget )
 268     image-style [ nip <image-name> <icon> ] apply-style ;
 269
 270 : apply-background-style ( style gadget -- style gadget )
 271     background [ <solid> >>interior ] apply-style ;
 272
 273 : apply-character-style ( style gadget -- gadget )
 274     apply-font-style
 275     apply-background-style
 276     apply-image-style
 277     apply-presentation-style
 278     nip ; inline
 279
 280 ! Paragraph styles
 281
 282 : apply-wrap-style ( style pane -- style pane )
 283     wrap-margin [
 284         2dup <paragraph> >>prototype drop
 285         <paragraph> >>current
 286     ] apply-style ;
 287
 288 : apply-border-color-style ( style gadget -- style gadget )
 289     border-color [ <solid> >>boundary ] apply-style ;
 290
 291 : apply-page-color-style ( style gadget -- style gadget )
 292     page-color [ <solid> >>interior ] apply-style ;
 293
 294 : apply-inset-style ( style gadget -- style gadget )
 295     inset [ <border> ] apply-style ;
 296
 297 : apply-paragraph-style ( style pane -- pane )
 298     apply-inset-style
 299     apply-border-color-style
 300     apply-page-color-style
 301     apply-presentation-style
 302     nip ;
 303
 304 : remove-paragraph-styles ( style -- style' )
 305     [
 306         drop HS{
 307             wrap-margin border-color page-color inset presented
 308         } in?
 309     ] assoc-reject ;
 310
 311 TUPLE: styled-pane < pane style ;
 312
 313 : <styled-pane> ( style -- pane )
 314     f styled-pane new-pane apply-wrap-style swap >>style ;
 315
 316 M: styled-pane smash-pane
 317     [ style>> ] [ call-next-method apply-paragraph-style ] bi ;
 318
 319 : <styled-pane-stream> ( style pane-stream -- styled-stream )
 320     over
 321     [ <styled-pane> ]
 322     [ pane-stream boa ]
 323     [ remove-paragraph-styles <style-stream> ] tri* ;
 324
 325 : make-styled-pane ( style quot -- gadget )
 326     [ <styled-pane> ] dip '[ _ with-pane ] keep smash-pane ; inline
 327
 328 M: pane-stream make-block-stream
 329     <styled-pane-stream> ;
 330
 331 ! Tables
 332
 333 : apply-table-gap-style ( style grid -- style grid )
 334     table-gap [ >>gap ] apply-style ;
 335
 336 : apply-table-border-style ( style grid -- style grid )
 337     table-border [ <grid-lines> >>boundary ] apply-style ;
 338
 339 : <styled-grid> ( style grid -- grid )
 340     <grid>
 341     f >>fill?
 342     apply-table-gap-style
 343     apply-table-border-style
 344     apply-paragraph-style ;
 345
 346 M: pane-stream make-cell-stream
 347     drop f <styled-pane-stream> ;
 348
 349 M: pane-stream stream-write-table
 350     [
 351         swap [ [ stream>> pane>> smash-pane ] map ] map
 352         <styled-grid>
 353     ] dip write-gadget ;
 354
 355 ! Stream utilities
 356
 357 : pane-bl ( style gadget -- )
 358     swap " " <word-break-gadget> apply-character-style add-gadget drop ;
 359
 360 : <styled-label> ( style text -- gadget )
 361     <label>
 362     apply-font-style
 363     apply-background-style
 364     apply-image-style
 365     apply-presentation-style
 366     nip ;
 367
 368 M: styled-pane pane-label style>> "" <styled-label> ;
 369
 370 : pane-text ( string style gadget -- )
 371     [ swap <styled-label> ] [ swap add-gadget drop ] bi* ;
 372
 373 M: pack pane-line pane-text ;
 374
 375 M: paragraph pane-line
 376     { presented image-style } pick '[ _ key? ] any? [
 377         pane-text
 378     ] [
 379         [ split-words ] 2dip
 380         [ pane-bl ] [ pane-text ] bi-curry bi-curry
 381         interleave
 382     ] if ;
 383
 384 : caret>mark ( pane -- )
 385     dup caret>> >>mark relayout-1 ;
 386
 387 GENERIC: sloppy-pick-up* ( loc gadget -- n )
 388
 389 M: pack sloppy-pick-up*
 390     [ orientation>> ] [ children>> ] bi
 391     [ loc>> ] (fast-children-on) ;
 392
 393 M: gadget sloppy-pick-up*
 394     children>> [ contains-point? ] with find-last drop ;
 395
 396 M: f sloppy-pick-up*
 397     2drop f ;
 398
 399 : wet-and-sloppy ( loc gadget n -- newloc newgadget )
 400     swap nth-gadget [ loc>> v- ] keep ;
 401
 402 : sloppy-pick-up ( loc gadget -- path )
 403     2dup sloppy-pick-up* dup
 404     [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
 405     [ 3drop { } ]
 406     if ;
 407
 408 : move-caret ( pane loc -- )
 409     over screen-loc v- over sloppy-pick-up >>caret
 410     relayout-1 ;
 411
 412 : begin-selection ( pane -- )
 413     f >>selecting?
 414     dup hand-loc get-global move-caret
 415     f >>mark
 416     drop ;
 417
 418 : extend-selection ( pane -- )
 419     hand-moved? [
 420         [
 421             dup selecting?>> [
 422                 hand-loc get-global move-caret
 423             ] [
 424                 dup hand-clicked get-global child? [
 425                     t >>selecting?
 426                     [ hand-clicked set-global ]
 427                     [ hand-click-loc get-global move-caret ]
 428                     [ caret>mark ]
 429                     tri
 430                 ] [ drop ] if
 431             ] if
 432         ] [ dup caret>> gadget-at-path scroll>gadget ] bi
 433     ] [ drop ] if ;
 434
 435 : end-selection ( pane -- )
 436     dup selecting?>> hand-moved? or
 437     [ f >>selecting? ] dip
 438     [ [ com-copy-selection ] [ request-focus ] bi ]
 439     [ [ relayout-1 ] [ focus-input ] bi ]
 440     if ;
 441
 442 : select-to-caret ( pane -- )
 443     t >>selecting?
 444     [ dup mark>> [ dup caret>mark ] unless hand-loc get-global move-caret ]
 445     [ com-copy-selection ]
 446     [ request-focus ]
 447     tri ;
 448
 449 : pane-menu ( pane -- ) { com-copy } show-commands-menu ;
 450
 451 PRIVATE>
 452
 453 pane H{
 454     { T{ button-down } [ begin-selection ] }
 455     { T{ button-down f { S+ } 1 } [ select-to-caret ] }
 456     { T{ button-up f { S+ } 1 } [ end-selection ] }
 457     { T{ button-up } [ end-selection ] }
 458     { T{ drag { # 1 } } [ extend-selection ] }
 459     { copy-action [ com-copy ] }
 460     { T{ button-down f f 3 } [ pane-menu ] }
 461 } set-gestures
 462
 463 GENERIC: content-gadget ( object -- gadget/f )
 464
 465 M: object content-gadget drop f ;