basis/ui/tools/deploy/deploy.factor

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