basis/ui/gadgets/worlds/worlds-tests.factor

   1 USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
   2 namespaces models kernel accessors arrays ;
   3 IN: ui.gadgets.worlds.tests
   4
   5 ! Test focus behavior
   6 <gadget> "g1" set
   7
   8 : <test-world> ( gadget -- world )
   9     <world-attributes> "Hi" >>title swap 1array >>gadgets <world> ;
  10
  11 { } [
  12     "g1" get <test-world> "w" set
  13 ] unit-test
  14
  15 { } [ "g1" get request-focus ] unit-test
  16
  17 { t } [ "w" get focus>> "g1" get eq? ] unit-test
  18
  19 <gadget> "g1" set
  20 <gadget> "g2" set
  21 "g2" get "g1" get add-gadget drop
  22
  23 { } [
  24     "g2" get <test-world> "w" set
  25 ] unit-test
  26
  27 { } [ "g1" get request-focus ] unit-test
  28
  29 { t } [ "w" get focus>> "g2" get eq? ] unit-test
  30 { t } [ "g2" get focus>> "g1" get eq? ] unit-test
  31 { f } [ "g1" get focus>> ] unit-test
  32
  33 <gadget> "g1" set
  34 <gadget> "g2" set
  35 <gadget> "g3" set
  36 "g3" get "g1" get add-gadget drop
  37 "g3" get "g2" get add-gadget drop
  38
  39 { } [
  40     "g3" get <test-world> "w" set
  41 ] unit-test
  42
  43 { } [ "g1" get request-focus ] unit-test
  44 { } [ "g2" get unparent ] unit-test
  45 { t } [ "g3" get focus>> "g1" get eq? ] unit-test
  46
  47 { t } [ <gadget> dup <test-world> focusable-child eq? ] unit-test
  48
  49 TUPLE: focusing < gadget ;
  50
  51 : <focusing> ( -- gadget ) focusing new ;
  52
  53 TUPLE: focus-test < gadget ;
  54
  55 : <focus-test> ( -- gadget )
  56     focus-test new <focusing> add-gadget ;
  57
  58 M: focus-test focusable-child* gadget-child ;
  59
  60 <focus-test> "f" set
  61
  62 { } [ "f" get <test-world> request-focus ] unit-test
  63
  64 { t } [ "f" get focus>> "f" get gadget-child eq? ] unit-test
  65
  66 { t } [ "f" get gadget-child focusing? ] unit-test