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