extra/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 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 IN: ui.tools.deploy
  10
  11 TUPLE: deploy-gadget vocab settings ;
  12
  13 : bundle-name ( -- )
  14     deploy-name get <field>
  15     "Executable name:" label-on-left gadget, ;
  16
  17 : deploy-ui ( -- )
  18     deploy-ui? get
  19     "Include user interface framework" <checkbox> gadget, ;
  20
  21 : exit-when-windows-closed ( -- )
  22     "stop-after-last-window?" get
  23     "Exit when last UI window closed" <checkbox> gadget, ;
  24
  25 : io-settings ( -- )
  26     "Input/output support:" <label> gadget,
  27     deploy-io get deploy-io-options <radio-buttons> gadget, ;
  28
  29 : reflection-settings ( -- )
  30     "Reflection support:" <label> gadget,
  31     deploy-reflection get deploy-reflection-options <radio-buttons> gadget, ;
  32
  33 : advanced-settings ( -- )
  34     "Advanced:" <label> gadget,
  35     deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
  36     deploy-math? get "Rational and complex number support" <checkbox> gadget,
  37     deploy-threads? get "Threading support" <checkbox> gadget,
  38     deploy-random? get "Random number generator support" <checkbox> gadget,
  39     deploy-word-props? get "Retain all word properties" <checkbox> gadget,
  40     deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
  41     deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
  42
  43 : deploy-settings-theme ( gadget -- )
  44     { 10 10 } >>gap
  45     1 >>fill
  46     drop ;
  47
  48 : <deploy-settings> ( vocab -- control )
  49     default-config [ <model> ] assoc-map [
  50         [
  51             bundle-name
  52             deploy-ui
  53             os macosx? [ exit-when-windows-closed ] when
  54             io-settings
  55             reflection-settings
  56             advanced-settings
  57         ] make-pile dup deploy-settings-theme
  58         namespace <mapping> over set-gadget-model
  59     ] bind ;
  60
  61 : find-deploy-gadget ( gadget -- deploy-gadget )
  62     [ deploy-gadget? ] find-parent ;
  63
  64 : find-deploy-vocab ( gadget -- vocab )
  65     find-deploy-gadget deploy-gadget-vocab ;
  66
  67 : find-deploy-config ( gadget -- config )
  68     find-deploy-vocab deploy-config ;
  69
  70 : find-deploy-settings ( gadget -- settings )
  71     find-deploy-gadget deploy-gadget-settings ;
  72
  73 : com-revert ( gadget -- )
  74     dup find-deploy-config
  75     swap find-deploy-settings set-control-value ;
  76
  77 : com-save ( gadget -- )
  78     dup find-deploy-settings control-value
  79     swap find-deploy-vocab set-deploy-config ;
  80
  81 : com-deploy ( gadget -- )
  82     dup com-save
  83     dup find-deploy-vocab [ deploy ] curry call-listener
  84     close-window ;
  85
  86 : com-help ( -- )
  87     "ui.tools.deploy" help-window ;
  88
  89 \ com-help H{
  90     { +nullary+ t }
  91 } define-command
  92
  93 : com-close ( gadget -- )
  94     close-window ;
  95
  96 deploy-gadget "toolbar" f {
  97     { f com-close }
  98     { f 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 : buttons, ( -- )
 105     g <toolbar> { 10 10 } over set-pack-gap gadget, ;
 106
 107 : <deploy-gadget> ( vocab -- gadget )
 108     f deploy-gadget boa [
 109         dup <deploy-settings>
 110         g-> set-deploy-gadget-settings gadget,
 111         buttons,
 112     ] { 0 1 } build-pack
 113     dup deploy-settings-theme
 114     dup com-revert ;
 115
 116 : deploy-tool ( vocab -- )
 117     vocab-name dup <deploy-gadget> 10 <border>
 118     "Deploying \"" rot "\"" 3append open-window ;