basis/ui/tools/deploy/deploy.factor

   1 ! Copyright (C) 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ui.gadgets colors kernel ui.render namespaces
   4        models models.mapping sequences ui.gadgets.buttons
   5        ui.gadgets.packs ui.gadgets.labels tools.deploy.config
   6        namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
   7        ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
   8        tools.deploy vocabs ui.tools.workspace system accessors ;
   9
  10 IN: ui.tools.deploy
  11
  12 TUPLE: deploy-gadget < pack vocab settings ;
  13
  14 : bundle-name ( parent -- parent )
  15     deploy-name get <field>
  16     "Executable name:" label-on-left add-gadget ;
  17
  18 : deploy-ui ( parent -- parent )
  19     deploy-ui? get
  20     "Include user interface framework" <checkbox> add-gadget ;
  21
  22 : exit-when-windows-closed ( parent -- parent )
  23     "stop-after-last-window?" get
  24     "Exit when last UI window closed" <checkbox> add-gadget ;
  25
  26 : io-settings ( parent -- parent )
  27     "Input/output support:" <label> add-gadget
  28     deploy-io get deploy-io-options <radio-buttons> add-gadget ;
  29
  30 : reflection-settings ( parent -- parent )
  31     "Reflection support:" <label> add-gadget
  32     deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
  33
  34 : advanced-settings ( parent -- parent )
  35     "Advanced:" <label> add-gadget
  36     deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
  37     deploy-math? get "Rational and complex number support" <checkbox> add-gadget
  38     deploy-threads? get "Threading support" <checkbox> add-gadget
  39     deploy-random? get "Random number generator support" <checkbox> add-gadget
  40     deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
  41     deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
  42     deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
  43
  44 : deploy-settings-theme ( gadget -- gadget )
  45     { 10 10 } >>gap
  46     1 >>fill ;
  47
  48 : <deploy-settings> ( vocab -- control )
  49     default-config [ <model> ] assoc-map
  50         [
  51             <pile>
  52             bundle-name
  53             deploy-ui
  54             os macosx? [ exit-when-windows-closed ] when
  55             io-settings
  56             reflection-settings
  57             advanced-settings
  58
  59             deploy-settings-theme
  60             namespace <mapping> >>model
  61         ]
  62     bind ;
  63
  64 : find-deploy-gadget ( gadget -- deploy-gadget )
  65     [ deploy-gadget? ] find-parent ;
  66
  67 : find-deploy-vocab ( gadget -- vocab )
  68     find-deploy-gadget vocab>> ;
  69
  70 : find-deploy-config ( gadget -- config )
  71     find-deploy-vocab deploy-config ;
  72
  73 : find-deploy-settings ( gadget -- settings )
  74     find-deploy-gadget settings>> ;
  75
  76 : com-revert ( gadget -- )
  77     dup find-deploy-config
  78     swap find-deploy-settings set-control-value ;
  79
  80 : com-save ( gadget -- )
  81     dup find-deploy-settings control-value
  82     swap find-deploy-vocab set-deploy-config ;
  83
  84 : com-deploy ( gadget -- )
  85     dup com-save
  86     dup find-deploy-vocab [ deploy ] curry call-listener
  87     close-window ;
  88
  89 : com-help ( -- )
  90     "ui.tools.deploy" help-window ;
  91
  92 \ com-help H{
  93     { +nullary+ t }
  94 } define-command
  95
  96 : com-close ( gadget -- )
  97     close-window ;
  98
  99 deploy-gadget "toolbar" f {
 100     { f com-close }
 101     { f com-help }
 102     { f com-revert }
 103     { f com-save }
 104     { T{ key-down f f "RET" } com-deploy }
 105 } define-command-map
 106
 107 : <deploy-gadget> ( vocab -- gadget )
 108     deploy-gadget new-gadget
 109       over                           >>vocab
 110       { 0 1 }                        >>orientation
 111       swap <deploy-settings>         >>settings
 112       dup settings>>                 add-gadget
 113       dup <toolbar> { 10 10 } >>gap  add-gadget
 114     deploy-settings-theme
 115     dup com-revert ;
 116
 117 : deploy-tool ( vocab -- )
 118     vocab-name dup <deploy-gadget> 10 <border>
 119     "Deploying \"" rot "\"" 3append open-window ;