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 models tools.deploy.config
   4 tools.deploy.config.editor tools.deploy vocabs namespaces
   5 models.mapping sequences system accessors fry ui.gadgets ui.render
   6 ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
   7 ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands assocs
   8 ui.gadgets.tracks ui ui.tools.listener ui.tools.browser ;
   9 IN: ui.tools.deploy
  10
  11 TUPLE: deploy-gadget < pack vocab settings ;
  12
  13 : bundle-name ( parent -- parent )
  14     deploy-name get <model-field>
  15     "Executable name:" label-on-left add-gadget ;
  16
  17 : deploy-console ( parent -- parent )
  18     deploy-console? get
  19     "Deploy as console application" <checkbox> add-gadget ;
  20
  21 : deploy-ui ( parent -- parent )
  22     deploy-ui? get
  23     "Include user interface framework" <checkbox> add-gadget ;
  24
  25 : reflection-settings ( parent -- parent )
  26     "Reflection level:" <label> add-gadget
  27     deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
  28
  29 : advanced-settings ( parent -- parent )
  30     "Additional reflection:" <label> add-gadget
  31     deploy-unicode? get "Unicode character literal table" <checkbox> add-gadget
  32     deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
  33     deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
  34     deploy-c-types? get "Retain all C types" <checkbox> add-gadget
  35     deploy-help? get "Retain documentation" <checkbox> add-gadget ;
  36
  37 : deploy-settings-theme ( gadget -- gadget )
  38     { 10 10 } >>gap
  39     1 >>fill ;
  40
  41 : <deploy-settings> ( vocab -- control )
  42     default-config [ <model> ] assoc-map [
  43         <pile>
  44         bundle-name
  45         deploy-ui
  46         deploy-console
  47         reflection-settings
  48         advanced-settings
  49
  50         deploy-settings-theme
  51         namespace <mapping> >>model
  52     ] with-variables ;
  53
  54 : find-deploy-gadget ( gadget -- deploy-gadget )
  55     [ deploy-gadget? ] find-parent ;
  56
  57 : find-deploy-vocab ( gadget -- vocab )
  58     find-deploy-gadget vocab>> ;
  59
  60 : find-deploy-config ( gadget -- config )
  61     find-deploy-vocab deploy-config ;
  62
  63 : find-deploy-settings ( gadget -- settings )
  64     find-deploy-gadget settings>> ;
  65
  66 : com-revert ( gadget -- )
  67     dup find-deploy-config
  68     swap find-deploy-settings set-control-value ;
  69
  70 : com-save ( gadget -- )
  71     dup find-deploy-settings control-value
  72     swap find-deploy-vocab set-deploy-config ;
  73
  74 : com-deploy ( gadget -- )
  75     [ com-save ]
  76     [ find-deploy-vocab '[ _ deploy ] \ deploy call-listener ]
  77     [ close-window ]
  78     tri ;
  79
  80 : com-help ( -- )
  81     "ui.tools.deploy" com-browse ;
  82
  83 \ com-help H{
  84     { +nullary+ t }
  85 } define-command
  86
  87 : com-close ( gadget -- )
  88     close-window ;
  89
  90 deploy-gadget "misc" "Miscellaneous commands" {
  91     { T{ key-down f f "ESC" } com-close }
  92 } define-command-map
  93
  94 deploy-gadget "toolbar" f {
  95     { T{ key-down f f "F1" } com-help }
  96     { f com-revert }
  97     { f com-save }
  98     { T{ key-down f f "RET" } com-deploy }
  99 } define-command-map
 100
 101 : <deploy-gadget> ( vocab -- gadget )
 102     deploy-gadget new
 103       over >>vocab
 104       vertical >>orientation
 105       swap <deploy-settings> >>settings
 106       dup settings>> add-gadget
 107       dup <toolbar> { 10 10 } >>gap add-gadget
 108     deploy-settings-theme
 109     dup com-revert ;
 110
 111 : deploy-tool ( vocab -- )
 112     vocab-name
 113     [ <deploy-gadget> { 10 10 } <border> ]
 114     [ "Deploying “" "”" surround ] bi
 115     open-window ;