basis/ui/tools/deploy/deploy.factor

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