basis/ui/ui.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs boxes classes.tuple
   4 classes.tuple.parser combinators combinators.short-circuit
   5 concurrency.flags concurrency.promises continuations deques
   6 destructors dlists fry init kernel lexer make math namespaces
   7 parser sequences sets strings threads ui.backend ui.gadgets
   8 ui.gadgets.private ui.gadgets.worlds ui.gestures vocabs.parser
   9 words ;
  10 FROM: namespaces => change-global ;
  11 IN: ui
  12
  13 <PRIVATE
  14
  15 ! Assoc mapping aliens to gadgets
  16 SYMBOL: windows
  17
  18 : window ( handle -- world ) windows get-global at ;
  19
  20 : register-window ( world handle -- )
  21     #! Add the new window just below the topmost window. Why?
  22     #! So that if the new window doesn't actually receive focus
  23     #! (eg, we're using focus follows mouse and the mouse is not
  24     #! in the new window when it appears) Factor doesn't get
  25     #! confused and send workspace operations to the new window,
  26     #! etc.
  27     swap 2array windows get-global push
  28     windows get-global dup length 1 >
  29     [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
  30
  31 : unregister-window ( handle -- )
  32     windows [ [ first = ] with reject ] change-global ;
  33
  34 : raised-window ( world -- )
  35     windows get-global
  36     [ [ second eq? ] with find drop ] keep
  37     [ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
  38
  39 : focus-gestures ( new old -- )
  40     drop-prefix <reversed>
  41     lose-focus swap each-gesture
  42     gain-focus swap each-gesture ;
  43
  44 : ?grab-input ( world -- )
  45     dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
  46
  47 : ?ungrab-input ( world -- )
  48     dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
  49
  50 : focus-world ( world -- )
  51     t >>focused?
  52     [ ?grab-input ] [
  53         dup raised-window
  54         focus-path f focus-gestures
  55     ] bi ;
  56
  57 : unfocus-world ( world -- )
  58     f >>focused?
  59     [ ?ungrab-input ]
  60     [ focus-path f swap focus-gestures ] bi ;
  61
  62 : set-up-window ( world -- )
  63     {
  64         [ set-gl-context ]
  65         [ [ title>> ] keep set-title ]
  66         [ begin-world ]
  67         [ resize-world ]
  68         [ t >>active? drop ]
  69         [ request-focus ]
  70     } cleave ;
  71
  72 : clean-up-broken-window ( world -- )
  73     [
  74         dup { [ focused?>> ] [ grab-input?>> ] } 1&&
  75         [ handle>> (ungrab-input) ] [ drop ] if
  76     ] [ handle>> (close-window) ] bi ;
  77
  78 M: world graft*
  79     [ (open-window) ]
  80     [
  81         [ set-up-window ]
  82         [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
  83     ] bi ;
  84
  85 : dispose-window-resources ( world -- )
  86     [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ;
  87
  88 M: world ungraft*
  89     {
  90         [ set-gl-context ]
  91         [ text-handle>> [ dispose ] when* ]
  92         [ images>> [ dispose ] when* ]
  93         [ hand-clicked close-global ]
  94         [ hand-gadget close-global ]
  95         [ end-world ]
  96         [ dispose-window-resources ]
  97         [ unfocus-world ]
  98         [ [ (close-window) f ] change-handle drop ]
  99         [ promise>> t swap fulfill ]
 100     } cleave ;
 101
 102 : init-ui ( -- )
 103     <box> drag-timer set-global
 104     f hand-gadget set-global
 105     f hand-clicked set-global
 106     f hand-world set-global
 107     f world set-global
 108     <dlist> \ graft-queue set-global
 109     <dlist> \ layout-queue set-global
 110     <dlist> \ gesture-queue set-global
 111     V{ } clone windows set-global ;
 112
 113 : update-hand ( world -- )
 114     dup hand-world get-global eq?
 115     [ hand-loc get-global swap move-hand ] [ drop ] if ;
 116
 117 : (layout-queued) ( deque -- seq )
 118     [
 119         in-layout? on
 120         [
 121             dup layout find-world [ , ] when*
 122         ] slurp-deque
 123     ] { } make members ; inline
 124
 125 : layout-queued ( -- seq )
 126     layout-queue dup deque-empty?
 127     [ drop { } ] [ (layout-queued) ] if ;
 128
 129 : redraw-worlds ( seq -- )
 130     [ dup update-hand draw-world ] each ;
 131
 132 : send-queued-gestures ( -- )
 133     gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
 134
 135 : update-ui ( -- )
 136     notify-queued
 137     layout-queued
 138     redraw-worlds
 139     send-queued-gestures ;
 140
 141 SYMBOL: ui-thread
 142
 143 : ui-running ( quot -- )
 144     t \ ui-running set-global
 145     [ f \ ui-running set-global ] [ ] cleanup ; inline
 146
 147 PRIVATE>
 148
 149 : find-window ( quot: ( world -- ? ) -- world )
 150     [ windows get-global values ] dip
 151     '[ dup children>> [ ] [ nip first ] if-empty @ ]
 152     find-last nip ; inline
 153
 154 : ui-running? ( -- ? )
 155     \ ui-running get-global ;
 156
 157 <PRIVATE
 158
 159 : update-ui-loop ( -- )
 160     #! Note the logic: if update-ui fails, we open an error window
 161     #! and run one iteration of update-ui. If that also fails, well,
 162     #! the whole UI subsystem is broken so we exit out of the
 163     #! update-ui-loop.
 164     [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
 165     [
 166         ui-notify-flag get lower-flag
 167         [ update-ui ] [ ui-error update-ui ] recover
 168     ] while ;
 169
 170 : start-ui-thread ( -- )
 171     [ self ui-thread set-global update-ui-loop ]
 172     "UI update" spawn drop ;
 173
 174 : start-ui ( quot -- )
 175     call( -- ) notify-ui-thread start-ui-thread ;
 176
 177 : ?attributes ( gadget title/attributes -- attributes )
 178     dup string? [ <world-attributes> swap >>title ] [ clone ] if
 179     swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
 180
 181 PRIVATE>
 182
 183 : open-world-window ( world -- )
 184     dup pref-dim >>dim dup relayout graft ;
 185
 186 : open-window* ( gadget title/attributes -- window )
 187     ?attributes <world> [ open-world-window ] keep ;
 188
 189 : open-window ( gadget title/attributes -- )
 190     open-window* drop ;
 191
 192 : set-fullscreen ( gadget ? -- )
 193     [ find-world ] dip (set-fullscreen) ;
 194
 195 : fullscreen? ( gadget -- ? )
 196     find-world (fullscreen?) ;
 197
 198 : toggle-fullscreen ( gadget -- )
 199     dup fullscreen? not set-fullscreen ;
 200
 201 : raise-window ( gadget -- )
 202     find-world raise-window* ;
 203
 204 : topmost-window ( -- world )
 205     windows get-global last second ;
 206
 207 HOOK: close-window ui-backend ( gadget -- )
 208
 209 M: object close-window
 210     find-world [ ungraft ] when* ;
 211
 212 [
 213     f \ ui-running set-global
 214     <flag> ui-notify-flag set-global
 215 ] "ui" add-startup-hook
 216
 217 HOOK: resize-window ui-backend ( world dim -- )
 218 M: object resize-window 2drop ;
 219
 220 : relayout-window ( gadget -- )
 221     [ relayout ]
 222     [ find-world [ dup pref-dim resize-window ] when* ] bi ;
 223
 224 : with-ui ( quot: ( -- ) -- )
 225     ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
 226
 227 HOOK: beep ui-backend ( -- )
 228
 229 HOOK: system-alert ui-backend ( caption text -- )
 230
 231 : parse-main-window-attributes ( class -- attributes )
 232     "{" expect dup all-slots parse-tuple-literal-slots ;
 233
 234 : define-main-window ( word attributes quot -- )
 235     [
 236         '[ [ f _ clone @ open-window ] with-ui ] ( -- ) define-declared
 237     ] [ 2drop current-vocab main<< ] 3bi ;
 238
 239 SYNTAX: MAIN-WINDOW:
 240     scan-new-word
 241     world-attributes parse-main-window-attributes
 242     parse-definition
 243     define-main-window ;