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