basis/ui/gadgets/editors/editors.factor

   1 ! Copyright (C) 2006, 2011 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar colors.constants combinators
   4 combinators.short-circuit documents documents.elements fonts fry
   5 grouping kernel locals make math math.functions math.order math.ranges
   6 math.rectangles math.vectors models models.arrow namespaces opengl
   7 sequences sorting splitting timers ui.baseline-alignment ui.clipboards
   8 ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.line-support
   9 ui.gadgets.menus ui.gadgets.scrollers ui.gestures ui.pens.solid
  10 ui.render ui.text ui.theme unicode opengl.gl ;
  11 IN: ui.gadgets.editors
  12
  13 TUPLE: editor < line-gadget
  14     caret mark
  15     focused? blink blink-timer
  16     default-text
  17     preedit-start
  18     preedit-end
  19     preedit-selected-start
  20     preedit-selected-end
  21     preedit-selection-mode?
  22     preedit-underlines ;
  23
  24 GENERIC: preedit? ( gadget -- ? )
  25
  26 M: gadget preedit? drop f ;
  27
  28 M: editor preedit? preedit-start>> [ t ] [ f ] if ;
  29
  30 <PRIVATE
  31
  32 : <loc> ( -- loc ) { 0 0 } <model> ;
  33
  34 : init-editor-locs ( editor -- editor )
  35     <loc> >>caret
  36     <loc> >>mark ; inline
  37
  38 : editor-theme ( editor -- editor )
  39     monospace-font >>font ; inline
  40
  41 PRIVATE>
  42
  43 : new-editor ( class -- editor )
  44     new-line-gadget
  45         <document> >>model
  46         init-editor-locs
  47         editor-theme ; inline
  48
  49 : <editor> ( -- editor )
  50     editor new-editor ;
  51
  52 <PRIVATE
  53
  54 : activate-editor-model ( editor model -- )
  55     [ add-connection ]
  56     [ nip activate-model ]
  57     [ swap model>> add-loc ] 2tri ;
  58
  59 : deactivate-editor-model ( editor model -- )
  60     [ remove-connection ]
  61     [ nip deactivate-model ]
  62     [ swap model>> remove-loc ] 2tri ;
  63
  64 : blink-caret ( editor -- )
  65     [ not ] change-blink relayout-1 ;
  66
  67 SYMBOL: blink-interval
  68
  69 750 milliseconds blink-interval set-global
  70
  71 : stop-blinking ( editor -- )
  72     blink-timer>> [ stop-timer ] when* ;
  73
  74 : start-blinking ( editor -- )
  75     t >>blink
  76     blink-timer>> [ restart-timer ] when* ;
  77
  78 : restart-blinking ( editor -- )
  79     dup focused?>> [
  80         [ start-blinking ]
  81         [ relayout-1 ]
  82         bi
  83     ] [ drop ] if ;
  84
  85 PRIVATE>
  86
  87 M: editor graft*
  88     [ dup caret>> activate-editor-model ]
  89     [ dup mark>> activate-editor-model ]
  90     [
  91         [
  92             '[ _ blink-caret ] blink-interval get dup <timer>
  93         ] keep blink-timer<<
  94     ] tri ;
  95
  96 M: editor ungraft*
  97     [ [ stop-blinking ] [ f >>blink-timer drop ] bi ]
  98     [ dup caret>> deactivate-editor-model ]
  99     [ dup mark>> deactivate-editor-model ] tri ;
 100
 101 : editor-caret ( editor -- loc ) caret>> value>> ;
 102
 103 : editor-mark ( editor -- loc ) mark>> value>> ;
 104
 105 : set-caret ( loc editor -- )
 106     [ model>> validate-loc ] [ caret>> ] bi set-model ;
 107
 108 : set-mark ( loc editor -- )
 109     [ model>> validate-loc ] [ mark>> ] bi set-model ;
 110
 111 : change-caret ( editor quot: ( loc document -- newloc ) -- )
 112     [ [ [ editor-caret ] [ model>> ] bi ] dip call ] [ drop ] 2bi
 113     set-caret ; inline
 114
 115 : mark>caret ( editor -- )
 116     [ editor-caret ] [ mark>> ] bi set-model ;
 117
 118 : change-caret&mark ( editor quot: ( loc document -- newloc ) -- )
 119     [ change-caret ] [ drop mark>caret ] 2bi ; inline
 120
 121 : editor-line ( n editor -- str ) control-value nth ;
 122
 123 :: point>loc ( point editor -- loc )
 124     point second editor y>line {
 125         { [ dup 0 < ] [ drop { 0 0 } ] }
 126         { [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
 127         [| n |
 128             n
 129             point first
 130             editor font>>
 131             n editor editor-line
 132             x>offset 2array
 133         ]
 134     } cond ;
 135
 136 : clicked-loc ( editor -- loc )
 137     [ hand-rel ] keep point>loc ;
 138
 139 : click-loc ( editor model -- )
 140     [ clicked-loc ] dip set-model ;
 141
 142 : focus-editor ( editor -- )
 143     [ start-blinking ] [ t >>focused? relayout-1 ] bi ;
 144
 145 : unfocus-editor ( editor -- )
 146     [ stop-blinking ] [ f >>focused? relayout-1 ] bi ;
 147
 148 : loc>x ( loc editor -- x )
 149     [ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x round ;
 150
 151 : loc>point ( loc editor -- loc )
 152     [ loc>x ] [ [ first ] dip line>y ceiling ] 2bi 2array ;
 153
 154 : caret-loc ( editor -- loc )
 155     [ editor-caret ] keep loc>point ;
 156
 157 : caret-dim ( editor -- dim )
 158     [ 0 ] dip line-height 2array ;
 159
 160 : scroll>caret ( editor -- )
 161     dup graft-state>> second [
 162         [
 163             [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
 164         ] keep scroll>rect
 165     ] [ drop ] if ;
 166
 167 <PRIVATE
 168
 169 : draw-caret? ( editor -- ? )
 170     { [ focused?>> ] [ blink>> ]
 171       [ [ preedit? not ] [ preedit-selection-mode?>> not ] bi or ] } 1&& ;
 172
 173 : draw-caret ( editor -- )
 174     dup draw-caret? [
 175         [ editor-caret-color gl-color ] dip
 176         [ caret-loc ] [ caret-dim ] bi
 177         over v+ gl-line
 178     ] [ drop ] if ;
 179
 180 :: draw-preedit-underlines ( editor -- )
 181     editor [ preedit? ] [ preedit-underlines>> ] bi and [
 182         editor [ caret-loc second ] [ caret-dim second ] bi + 2.0 - :> y
 183         editor editor-caret first :> row
 184         editor font>> foreground>> gl-color
 185         editor preedit-underlines>> [
 186             GL_LINE_BIT [
 187                 dup second glLineWidth
 188                 first editor preedit-start>> second dup 2array v+ first2
 189                 [ row swap 2array editor loc>x 1.0 + y 2array ]
 190                 [ row swap 2array editor loc>x 1.0 - y 2array ]
 191                 bi*
 192                 gl-line
 193             ] do-attribs
 194         ] each
 195     ] when ;
 196
 197 : selection-start/end ( editor -- start end )
 198     [ editor-mark ] [ editor-caret ] bi sort-pair ;
 199
 200 SYMBOL: selected-lines
 201
 202 TUPLE: selected-line start end first? last? ;
 203
 204 : compute-selection ( editor -- assoc )
 205     dup gadget-selection? [
 206         [ selection-start/end [ [ first ] bi@ [a,b] ] [ ] 2bi ]
 207         [ model>> ] bi
 208         '[ [ _ _ ] [ _ start/end-on-line ] bi 2array ] H{ } map>assoc
 209     ] [ drop f ] if ;
 210
 211 :: draw-selection ( line pair editor -- )
 212     pair [ editor font>> line offset>x ] map :> pair
 213     editor selection-color>> gl-color
 214     pair first 0 2array
 215     pair second pair first - round 1 max editor line-height 2array
 216     gl-fill-rect ;
 217
 218 : draw-unselected-line ( line editor -- )
 219     font>> swap draw-text ;
 220
 221 : draw-selected-line ( line pair editor -- )
 222     over all-equal? [
 223         [ nip draw-unselected-line ] [ draw-selection ] 3bi
 224     ] [
 225         [ draw-selection ]
 226         [
 227             [ [ first2 ] [ selection-color>> ] bi* <selection> ]
 228             [ draw-unselected-line ] bi
 229         ] 3bi
 230     ] if ;
 231
 232 : draw-default-text? ( editor -- ? )
 233     { [ default-text>> ] [ model>> doc-string empty? ] } 1&& ;
 234
 235 : draw-default-text ( editor -- )
 236     [ font>> clone line-color >>foreground ]
 237     [ default-text>> ] bi draw-text ;
 238
 239 PRIVATE>
 240
 241 M: editor draw-line ( line index editor -- )
 242     [ selected-lines get at ] dip over
 243     [ draw-selected-line ] [ nip draw-unselected-line ] if ;
 244
 245 M: editor draw-gadget*
 246     dup draw-default-text? [
 247         [ draw-default-text ] [ draw-caret ] [ draw-preedit-underlines ] tri
 248     ] [
 249         dup compute-selection selected-lines [
 250             [ draw-lines ] [ draw-caret ] [ draw-preedit-underlines ] tri
 251         ] with-variable
 252     ] if ;
 253
 254 M: editor pref-dim*
 255     ! Add some space for the caret.
 256     [ font>> ] keep dup draw-default-text?
 257     [ default-text>> ] [ control-value ] if
 258     text-dim { 1 0 } v+ ;
 259
 260 M: editor baseline font>> font-metrics ascent>> ;
 261
 262 M: editor cap-height font>> font-metrics cap-height>> ;
 263
 264 <PRIVATE
 265
 266 : contents-changed ( model editor -- )
 267     [ [ nip caret>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
 268     [ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
 269     [ nip relayout ] 2tri ;
 270
 271 : caret/mark-changed ( editor -- )
 272     [ restart-blinking ] keep scroll>caret ;
 273
 274 PRIVATE>
 275
 276 M: editor model-changed
 277     {
 278         { [ 2dup model>> eq? ] [ contents-changed ] }
 279         { [ 2dup caret>> eq? ] [ nip caret/mark-changed ] }
 280         { [ 2dup mark>> eq? ] [ nip caret/mark-changed ] }
 281     } cond ;
 282
 283 M: editor gadget-selection?
 284     selection-start/end = not ;
 285
 286 M: editor gadget-selection
 287     [ selection-start/end ] [ model>> ] bi doc-range ;
 288
 289 : remove-selection ( editor -- )
 290     [ selection-start/end ] [ model>> ] bi remove-doc-range ;
 291
 292 M: editor user-input*
 293     [ selection-start/end ] [ model>> ] bi set-doc-range t ;
 294
 295 M: editor temp-im-input
 296     [ selection-start/end ] [ model>> ] bi set-doc-range* t ;
 297
 298 : editor-string ( editor -- string )
 299     model>> doc-string ;
 300
 301 : set-editor-string ( string editor -- )
 302     model>> set-doc-string ;
 303
 304 M: editor gadget-text* editor-string % ;
 305
 306 : extend-selection ( editor -- )
 307     [ request-focus ]
 308     [ restart-blinking ]
 309     [ dup caret>> click-loc ] tri ;
 310
 311 : remove-preedit-text ( editor -- )
 312     { [ preedit-start>> ] [ set-caret ]
 313       [ preedit-end>> ] [ set-mark ]
 314       [ remove-selection ]
 315     } cleave ;
 316
 317 : remove-preedit-info ( editor -- )
 318     f >>preedit-start
 319     f >>preedit-end
 320     f >>preedit-selected-start
 321     f >>preedit-selected-end
 322     f >>preedit-selection-mode?
 323     f >>preedit-underlines
 324     drop ;
 325
 326 : mouse-elt ( -- element )
 327     hand-click# get {
 328         { 1 one-char-elt }
 329         { 2 one-word-elt }
 330     } at one-line-elt or ;
 331
 332 : drag-direction? ( loc editor -- ? )
 333     editor-mark before? ;
 334
 335 : drag-selection-caret ( loc editor element -- loc )
 336     [
 337         [ drag-direction? ] [ model>> ] 2bi
 338     ] dip prev/next-elt ? ;
 339
 340 : drag-selection-mark ( loc editor element -- loc )
 341     [
 342         [ drag-direction? not ]
 343         [ editor-mark ]
 344         [ model>> ] tri
 345     ] dip prev/next-elt ? ;
 346
 347 : drag-caret&mark ( editor -- caret mark )
 348     [ clicked-loc ] [ mouse-elt ] bi
 349     [ drag-selection-caret ]
 350     [ drag-selection-mark ] 3bi ;
 351
 352 : drag-selection ( editor -- )
 353     [ drag-caret&mark ]
 354     [ mark>> set-model ]
 355     [ caret>> set-model ] tri ;
 356
 357 : editor-cut ( editor clipboard -- )
 358     [ gadget-copy ] [ drop remove-selection ] 2bi ;
 359
 360 : delete/backspace ( editor quot -- )
 361     over gadget-selection? [
 362         drop remove-selection
 363     ] [
 364         [ [ [ editor-caret ] [ model>> ] bi ] dip call ]
 365         [ drop model>> ]
 366         2bi remove-doc-range
 367     ] if ; inline
 368
 369 : editor-delete ( editor elt -- )
 370     '[ dupd _ next-elt ] delete/backspace ;
 371
 372 : editor-backspace ( editor elt -- )
 373     '[ over [ _ prev-elt ] dip ] delete/backspace ;
 374
 375 : editor-select-prev ( editor elt -- )
 376     '[ _ prev-elt ] change-caret ;
 377
 378 : editor-prev ( editor elt -- )
 379     [ editor-select-prev ] [ drop mark>caret ] 2bi ;
 380
 381 : editor-select-next ( editor elt -- )
 382     '[ _ next-elt ] change-caret ;
 383
 384 : editor-next ( editor elt -- )
 385     dupd editor-select-next mark>caret ;
 386
 387 : editor-select ( from to editor -- )
 388     [ mark>> set-model ] [ caret>> set-model ] bi-curry bi* ;
 389
 390 : select-elt ( editor elt -- )
 391     [ [ [ editor-caret ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
 392     editor-select ;
 393
 394 : start-of-document ( editor -- ) doc-elt editor-prev ;
 395
 396 : end-of-document ( editor -- ) doc-elt editor-next ;
 397
 398 : position-caret ( editor -- )
 399     mouse-elt dup one-char-elt =
 400     [ drop dup extend-selection dup mark>> click-loc ]
 401     [ select-elt ] if ;
 402
 403 : delete-previous-character ( editor -- )
 404     char-elt editor-backspace ;
 405
 406 : delete-next-character ( editor -- )
 407     char-elt editor-delete ;
 408
 409 : delete-previous-word ( editor -- )
 410     word-elt editor-backspace ;
 411
 412 : delete-next-word ( editor -- )
 413     word-elt editor-delete ;
 414
 415 : delete-to-start-of-line ( editor -- )
 416     one-line-elt editor-backspace ;
 417
 418 : delete-to-end-of-line ( editor -- )
 419     one-line-elt editor-delete ;
 420
 421 : delete-to-start-of-document ( editor -- )
 422     doc-elt editor-delete ;
 423
 424 : delete-to-end-of-document ( editor -- )
 425     doc-elt editor-delete ;
 426
 427 : com-undo ( editor -- ) model>> undo ;
 428
 429 : com-redo ( editor -- ) model>> redo ;
 430
 431 editor "editing" f {
 432     { undo-action com-undo }
 433     { redo-action com-redo }
 434     { T{ key-down f f "DELETE" } delete-next-character }
 435     { T{ key-down f f "BACKSPACE" } delete-previous-character }
 436     { T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
 437     { T{ key-down f { C+ } "DELETE" } delete-next-word }
 438     { T{ key-down f { C+ } "BACKSPACE" } delete-previous-word }
 439     { T{ key-down f { A+ } "DELETE" } delete-to-end-of-line }
 440     { T{ key-down f { A+ } "BACKSPACE" } delete-to-start-of-line }
 441 } define-command-map
 442
 443 : com-paste ( editor -- ) clipboard get paste-clipboard ;
 444
 445 : paste-selection ( editor -- ) ui.clipboards:selection get paste-clipboard ;
 446
 447 : com-cut ( editor -- ) clipboard get editor-cut ;
 448
 449 editor "clipboard" f {
 450     { cut-action com-cut }
 451     { copy-action com-copy }
 452     { paste-action com-paste }
 453     { T{ button-up } com-copy-selection }
 454     { T{ button-up f f 2 } paste-selection }
 455 } define-command-map
 456
 457 : previous-character ( editor -- )
 458     dup gadget-selection? [
 459         dup selection-start/end drop
 460         over set-caret mark>caret
 461     ] [
 462         char-elt editor-prev
 463     ] if ;
 464
 465 : next-character ( editor -- )
 466     dup gadget-selection? [
 467         dup selection-start/end nip
 468         over set-caret mark>caret
 469     ] [
 470         char-elt editor-next
 471     ] if ;
 472
 473 : previous-word ( editor -- ) word-elt editor-prev ;
 474
 475 : next-word ( editor -- ) word-elt editor-next ;
 476
 477 : start-of-line ( editor -- ) one-line-elt editor-prev ;
 478
 479 : end-of-line ( editor -- ) one-line-elt editor-next ;
 480
 481 editor "caret-motion" f {
 482     { T{ button-down } position-caret }
 483     { T{ key-down f f "LEFT" } previous-character }
 484     { T{ key-down f f "RIGHT" } next-character }
 485     { T{ key-down f { C+ } "LEFT" } previous-word }
 486     { T{ key-down f { C+ } "RIGHT" } next-word }
 487     { T{ key-down f f "HOME" } start-of-line }
 488     { T{ key-down f f "END" } end-of-line }
 489     { T{ key-down f { C+ } "HOME" } start-of-document }
 490     { T{ key-down f { C+ } "END" } end-of-document }
 491 } define-command-map
 492
 493 : clear-editor ( editor -- )
 494     model>> clear-doc ;
 495
 496 : select-all ( editor -- ) doc-elt select-elt ;
 497
 498 : select-line ( editor -- ) one-line-elt select-elt ;
 499
 500 : select-word ( editor -- ) one-word-elt select-elt ;
 501
 502 : selected-token ( editor -- string )
 503     dup gadget-selection?
 504     [ dup select-word ] unless
 505     gadget-selection ;
 506
 507 : select-previous-character ( editor -- )
 508     char-elt editor-select-prev ;
 509
 510 : select-next-character ( editor -- )
 511     char-elt editor-select-next ;
 512
 513 : select-previous-word ( editor -- )
 514     word-elt editor-select-prev ;
 515
 516 : select-next-word ( editor -- )
 517     word-elt editor-select-next ;
 518
 519 : select-start-of-line ( editor -- )
 520     one-line-elt editor-select-prev ;
 521
 522 : select-end-of-line ( editor -- )
 523     one-line-elt editor-select-next ;
 524
 525 : select-start-of-document ( editor -- )
 526     doc-elt editor-select-prev ;
 527
 528 : select-end-of-document ( editor -- )
 529     doc-elt editor-select-next ;
 530
 531 editor "selection" f {
 532     { T{ button-down f { S+ } 1 } extend-selection }
 533     { T{ button-up f { S+ } 1 } com-copy-selection }
 534     { T{ drag { # 1 } } drag-selection }
 535     { gain-focus focus-editor }
 536     { lose-focus unfocus-editor }
 537     { delete-action remove-selection }
 538     { select-all-action select-all }
 539     { T{ key-down f { C+ } "l" } select-line }
 540     { T{ key-down f { S+ } "LEFT" } select-previous-character }
 541     { T{ key-down f { S+ } "RIGHT" } select-next-character }
 542     { T{ key-down f { S+ C+ } "LEFT" } select-previous-word }
 543     { T{ key-down f { S+ C+ } "RIGHT" } select-next-word }
 544     { T{ key-down f { S+ } "HOME" } select-start-of-line }
 545     { T{ key-down f { S+ } "END" } select-end-of-line }
 546     { T{ key-down f { S+ C+ } "HOME" } select-start-of-document }
 547     { T{ key-down f { S+ C+ } "END" } select-end-of-document }
 548 } define-command-map
 549
 550 : editor-menu ( editor -- )
 551     {
 552         com-undo
 553         com-redo
 554         ----
 555         com-cut
 556         com-copy
 557         com-paste
 558     } show-commands-menu ;
 559
 560 editor "misc" f {
 561     ! { T{ button-down f f 2 } paste-selection }
 562     { T{ button-down f f 3 } editor-menu }
 563 } define-command-map
 564
 565 ! Multi-line editors
 566 TUPLE: multiline-editor < editor ;
 567
 568 : <multiline-editor> ( -- editor )
 569     multiline-editor new-editor ;
 570
 571 : previous-line ( editor -- ) line-elt editor-prev ;
 572
 573 : next-line ( editor -- ) line-elt editor-next ;
 574
 575 <PRIVATE
 576
 577 : page-elt ( editor -- editor element ) dup visible-lines 1 - <page-elt> ;
 578
 579 PRIVATE>
 580
 581 : previous-page ( editor -- ) page-elt editor-prev ;
 582
 583 : next-page ( editor -- ) page-elt editor-next ;
 584
 585 : select-previous-line ( editor -- ) line-elt editor-select-prev ;
 586
 587 : select-next-line ( editor -- ) line-elt editor-select-next ;
 588
 589 : select-previous-page ( editor -- ) page-elt editor-select-prev ;
 590
 591 : select-next-page ( editor -- ) page-elt editor-select-next ;
 592
 593 : insert-newline ( editor -- )
 594     "\n" swap user-input* drop ;
 595
 596 : change-selection ( editor quot -- )
 597     '[ gadget-selection @ ] [ user-input* drop ] bi ; inline
 598
 599 <PRIVATE
 600
 601 : join-lines ( string -- string' )
 602     "\n" split
 603     [ rest-slice [ [ blank? ] trim-head-slice ] map! drop ]
 604     [ but-last-slice [ [ blank? ] trim-tail-slice ] map! drop ]
 605     [ " " join ]
 606     tri ;
 607
 608 : last-line? ( document line -- ? )
 609     [ last-line# ] dip = ;
 610
 611 : prev-line-and-this ( document line -- start end )
 612     swap [ drop 1 - 0 2array ] [ line-end ] 2bi ;
 613
 614 : join-with-prev ( document line -- )
 615     [ prev-line-and-this ] [ drop ] 2bi
 616     [ join-lines ] change-doc-range ;
 617
 618 : this-line-and-next ( document line -- start end )
 619     swap [ drop 0 2array ] [ [ 1 + ] dip line-end ] 2bi ;
 620
 621 : join-with-next ( document line -- )
 622     [ this-line-and-next ] [ drop ] 2bi
 623     [ join-lines ] change-doc-range ;
 624
 625 PRIVATE>
 626
 627 : com-join-lines ( editor -- )
 628     dup gadget-selection?
 629     [ [ join-lines ] change-selection ] [
 630         [ model>> ] [ editor-caret first ] bi {
 631             { [ over last-line# 0 = ] [ 2drop ] }
 632             { [ 2dup last-line? ] [ join-with-prev ] }
 633             [ join-with-next ]
 634         } cond
 635     ] if ;
 636
 637 multiline-editor "multiline" f {
 638     { T{ key-down f f "UP" } previous-line }
 639     { T{ key-down f f "DOWN" } next-line }
 640     { T{ key-down f { S+ } "UP" } select-previous-line }
 641     { T{ key-down f { S+ } "DOWN" } select-next-line }
 642     { T{ key-down f f "PAGE_UP" } previous-page }
 643     { T{ key-down f f "PAGE_DOWN" } next-page }
 644     { T{ key-down f { S+ } "PAGE_UP" } select-previous-page }
 645     { T{ key-down f { S+ } "PAGE_DOWN" } select-next-page }
 646     { T{ key-down f f "RET" } insert-newline }
 647     { T{ key-down f { S+ } "RET" } insert-newline }
 648     { T{ key-down f f "ENTER" } insert-newline }
 649     { T{ key-down f { C+ } "j" } com-join-lines }
 650 } define-command-map
 651
 652 TUPLE: source-editor < multiline-editor ;
 653
 654 : <source-editor> ( -- editor )
 655     source-editor new-editor ;
 656
 657 ! A useful model
 658 : <element-model> ( editor element -- model )
 659     [ [ caret>> ] [ model>> ] bi ] dip
 660     '[ _ _ elt-string ] <arrow> ;
 661
 662 ! Fields wrap an editor
 663 TUPLE: field < border editor min-cols max-cols ;
 664
 665 <PRIVATE
 666
 667 : field-theme ( gadget -- gadget )
 668     { 2 2 } >>size
 669     { 1 0 } >>fill
 670     field-border-color <solid> >>boundary ; inline
 671
 672 : <field-border> ( gadget -- border )
 673     border new-border field-theme ;
 674
 675 PRIVATE>
 676
 677 : new-field ( class -- gadget )
 678     [ <editor> ] dip new-border
 679         dup gadget-child >>editor
 680         field-theme ; inline
 681
 682 ! For line-gadget-width
 683 M: field font>> editor>> font>> ;
 684
 685 M: field pref-dim*
 686     [ ]
 687     [ editor>> pref-dim ]
 688     [ [ line-gadget-width ] [ drop second ] 2bi 2array ]
 689     tri border-pref-dim ;
 690
 691 M: field default-text>> editor>> default-text>> ;
 692
 693 M: field default-text<< editor>> default-text<< ;
 694
 695 TUPLE: model-field < field field-model ;
 696
 697 : <model-field> ( model -- gadget )
 698     model-field new-field
 699         swap >>field-model ;
 700
 701 M: model-field graft*
 702     [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
 703     [ dup editor>> model>> add-connection ]
 704     bi ;
 705
 706 M: model-field ungraft*
 707     dup editor>> model>> remove-connection ;
 708
 709 M: model-field model-changed
 710     nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
 711
 712 TUPLE: action-field < field quot ;
 713
 714 : <action-field> ( quot: ( string -- ) -- gadget )
 715     action-field [ <editor> ] dip new-border
 716         dup gadget-child >>editor
 717         field-theme
 718         swap >>quot ;
 719
 720 : invoke-action-field ( field -- )
 721     [ editor>> editor-string ]
 722     [ editor>> clear-editor ]
 723     [ quot>> ]
 724     tri call( string -- ) ;
 725
 726 action-field H{
 727     { T{ key-down f f "RET" } [ invoke-action-field ] }
 728 } set-gestures