UI deploy tool

extra/tools/deploy/config/config-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax words alien.c-types assocs
-kernel ;
+kernel math ;
 IN: tools.deploy.config
 
 ARTICLE: "deploy-config" "Deployment configuration"
@@ -14,17 +14,13 @@ ARTICLE: "deploy-config" "Deployment configuration"
 ARTICLE: "deploy-flags" "Deployment flags"
 "There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:"
 { $subsection deploy-math?     }
-{ $subsection deploy-compiled? }
+{ $subsection deploy-compiler? }
-{ $subsection deploy-io?       }
 { $subsection deploy-ui?       }
 "The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
-{ $subsection strip-globals?     }
+{ $subsection deploy-io          }
-{ $subsection strip-word-props?  }
+{ $subsection deploy-reflection  }
-{ $subsection strip-word-names?  }
+{ $subsection deploy-word-props? }
-{ $subsection strip-dictionary?  }
+{ $subsection deploy-c-types?    } ;
-{ $subsection strip-debugger?    }
-{ $subsection strip-prettyprint? }
-{ $subsection strip-c-types?     } ;
 
 ARTICLE: "prepare-deploy" "Preparing to deploy an application"
 "In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
@@ -33,47 +29,22 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
 
 ABOUT: "prepare-deploy"
 
-HELP: strip-globals?
+HELP: deploy-word-props?
-{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace."
+{ $description "Deploy flag. If set, the deploy tool retains all word properties. Otherwise, it applies various heuristics to strip out un-needed word properties from words in the dictionary."
 $nl
-"On by default. Disable this if the heuristics strip out required variables." } ;
+"Off by default. Enable this if the heuristics strip out required word properties." } ;
 
-HELP: strip-word-props?
+HELP: deploy-c-types?
-{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary."
+{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table."
 $nl
-"On by default. Disable this if the heuristics strip out required word properties." } ;
+"Off by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
-
-HELP: strip-word-names?
-{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary."
-$nl
-"On by default. Disable this if your program calls " { $link word-name } "." } ;
-
-HELP: strip-dictionary?
-{ $description "Deploy flag. If set, the deploy tool strips unused words."
-$nl
-"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ;
-
-HELP: strip-debugger?
-{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM."
-$nl
-"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ;
-
-HELP: strip-prettyprint?
-{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter."
-$nl
-"On by default. Disable this if your program uses the prettyprinter." } ;
-
-HELP: strip-c-types?
-{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table."
-$nl
-"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
 
 HELP: deploy-math?
-{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
+{ $description "Deploy flag. If set, the deployed image will contain support for " { $link ratio } " and " { $link complex } " types."
 $nl
-"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
+"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
 
-HELP: deploy-compiled?
+HELP: deploy-compiler?
 { $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
 $nl
 "On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
@@ -83,10 +54,11 @@ HELP: deploy-ui?
 $nl
 "Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
 
-HELP: deploy-io?
+HELP: deploy-io
-{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image."
+{ $description "The level of I/O support required by the deployed image." } ;
-$nl
+
-"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ;
+HELP: deploy-reflection
+{ $description "The level of reflection support required by the deployed image." } ;
 
 HELP: default-config
 { $values { "assoc" assoc } }

extra/tools/deploy/config/config.factor

@@ -1,40 +1,58 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: vocabs.loader io.files io kernel sequences assocs
-splitting parser prettyprint ;
+splitting parser prettyprint namespaces math ;
 IN: tools.deploy.config
 
-SYMBOL: strip-io?
-SYMBOL: strip-globals?
-SYMBOL: strip-word-props?
-SYMBOL: strip-word-names?
-SYMBOL: strip-dictionary?
-SYMBOL: strip-debugger?
-SYMBOL: strip-prettyprint?
-SYMBOL: strip-c-types?
-
-SYMBOL: deploy-math?
-SYMBOL: deploy-compiled?
-SYMBOL: deploy-io?
 SYMBOL: deploy-ui?
+SYMBOL: deploy-compiler?
+SYMBOL: deploy-math?
+
+SYMBOL: deploy-io
+
+: deploy-io-options
+    {
+        { 1 "Level 1 - No input/output" }
+        { 2 "Level 2 - Basic ANSI C streams" }
+        { 3 "Level 3 - Non-blocking streams and networking" }
+    } ;
+
+: strip-io? deploy-io get zero? ;
+
+: native-io? deploy-io get 3 = ;
+
+SYMBOL: deploy-reflection
+
+: deploy-reflection-options
+    {
+        { 1 "Level 1 - No reflection" }
+        { 2 "Level 2 - Retain word names" }
+        { 3 "Level 3 - Prettyprinter" }
+        { 4 "Level 4 - Debugger" }
+        { 5 "Level 5 - Parser" }
+        { 6 "Level 6 - Full environment" }
+    } ;
+
+: strip-word-names? deploy-reflection get 2 < ;
+: strip-prettyprint? deploy-reflection get 3 < ;
+: strip-debugger? deploy-reflection get 4 < ;
+: strip-dictionary? deploy-reflection get 5 < ;
+: strip-globals? deploy-reflection get 6 < ;
+
+SYMBOL: deploy-word-props?
+SYMBOL: deploy-c-types?
 
 SYMBOL: deploy-vm
 SYMBOL: deploy-image
 
 : default-config ( -- assoc )
     V{
-        { strip-io?          f }
+        { deploy-io                 2 }
-        { strip-prettyprint? t }
+        { deploy-reflection         1 }
-        { strip-globals?     t }
+        { deploy-compiler?          t }
-        { strip-word-props?  t }
-        { strip-word-names?  t }
-        { strip-dictionary?  t }
-        { strip-debugger?    t }
-        { strip-c-types?     t }
         { deploy-math?              t }
-        { deploy-compiled?   t }
+        { deploy-word-props?        f }
-        { deploy-io?         f }
+        { deploy-c-types?           f }
-        { deploy-ui?         f }
         ! default value for deploy.app
         { "stop-after-last-window?" t }
     } clone ;

extra/tools/deploy/deploy.factor

@@ -30,13 +30,16 @@ IN: tools.deploy
     dup duplex-stream-out stream-close
     copy-lines ;
 
+: ?append swap [ append ] [ drop ] if ;
+
 : profile-string ( config -- string )
-    {
+    [
-        { deploy-math? "math" }
+        ""
-        { deploy-compiled? "compiler" }
+        deploy-math? get " math" ?append
-        { deploy-ui? "ui" }
+        deploy-compiler? get " compiler" ?append
-        { deploy-io? "io" }
+        native-io? " io" ?append
-    } swap [ nip at ] curry assoc-subset values " " join ;
+        deploy-ui? get " ui" ?append
+    ] bind ;
 
 : deploy-command-line ( vm image vocab config -- vm flags )
     [

extra/tools/deploy/shaker/shaker.factor

@@ -16,10 +16,10 @@ IN: tools.deploy.shaker
 : strip-init-hooks ( -- )
     "Stripping startup hooks" show
     "command-line" init-hooks get delete-at
-    strip-io? get [ "io.backend" init-hooks get delete-at ] when ;
+    strip-io? [ "io.backend" init-hooks get delete-at ] when ;
 
 : strip-debugger ( -- )
-    strip-debugger? get [
+    strip-debugger? [
         "Stripping debugger" show
         "resource:extra/tools/deploy/shaker/strip-debugger.factor"
         run-file
@@ -65,23 +65,13 @@ IN: tools.deploy.shaker
 
 : strip-words ( props -- )
     [ word? ] instances
-    strip-word-props? get [ tuck strip-word-props ] [ nip ] if
+    deploy-word-props? get [ nip ] [ tuck strip-word-props ] if
-    strip-word-names? get [ dup strip-word-names ] when
+    strip-word-names? [ dup strip-word-names ] when
     strip-word-defs ;
 
-USING: bit-arrays byte-arrays io.streams.nested ;
-
-: strip-classes ( -- )
-    "Stripping classes" show
-    io-backend get [
-        c-reader forget
-        c-writer forget
-    ] when
-    { style-stream mirror enum } [ forget ] each ;
-
 : strip-environment ( retain-globals -- )
     "Stripping environment" show
-    strip-globals? get [
+    strip-globals? [
         global strip-assoc 21 setenv
     ] [ drop ] if ;
 
@@ -103,16 +93,16 @@ SYMBOL: deploy-vocab
         \ boot ,
         init-hooks get values concat %
         ,
-        strip-io? get [ \ flush , ] unless
+        strip-io? [ \ flush , ] unless
     ] [ ] make "Boot quotation: " write dup . flush
     set-boot-quot ;
 
 : retained-globals ( -- seq )
     [
         builtins ,
-        strip-io? get [ io-backend , ] unless
+        strip-io? [ io-backend , ] unless
 
-        strip-dictionary? get [
+        strip-dictionary? [
             {
                 builtins
                 dictionary
@@ -129,14 +119,14 @@ SYMBOL: deploy-vocab
             } %
         ] unless
 
-        strip-prettyprint? get [
+        strip-prettyprint? [
             {
                 tab-size
                 margin
             } %
         ] unless
 
-        strip-c-types? get not deploy-ui? get or [
+        deploy-c-types? get deploy-ui? get or [
             "c-types" "alien.c-types" lookup ,
         ] when
 
@@ -150,18 +140,7 @@ SYMBOL: deploy-vocab
         ] when
     ] { } make dup . ;
 
-: normalize-strip-flags
-    strip-prettyprint? get [
-        strip-word-names? off
-    ] unless
-    strip-dictionary? get [
-        strip-prettyprint? off
-        strip-word-names? off
-        strip-word-props? off
-    ] unless ;
-
 : strip ( -- )
-    normalize-strip-flags
     strip-cocoa
     strip-debugger
     strip-init-hooks

extra/ui/tools/deploy/deploy.factor

@@ -0,0 +1,91 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets colors kernel ui.render namespaces
+ui.gadgets.controls models sequences ui.gadgets.buttons
+ui.gadgets.packs ui.gadgets.labels tools.deploy.config
+namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
+ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
+tools.deploy.app vocabs ;
+IN: ui.tools.deploy
+
+TUPLE: deploy-gadget vocab settings ;
+
+: bundle-name ( -- )
+    "bundle-name" get <field> "Bundle name:" label-on-left gadget, ;
+
+: exit-when-windows-closed ( -- )
+    "stop-after-last-window?" get
+    "Exit when last UI window closed" <checkbox> gadget, ;
+
+: io-settings ( -- )
+    "Input/output support:" <label> gadget,
+    deploy-io get deploy-io-options <radio-buttons> gadget, ;
+
+: reflection-settings ( -- )
+    "Reflection support:" <label> gadget,
+    deploy-reflection get deploy-reflection-options <radio-buttons> gadget, ;
+
+: advanced-settings ( -- )
+    "Advanced:" <label> gadget,
+    deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
+    deploy-math? get "Rational and complex number support" <checkbox> gadget,
+    deploy-word-props? get "Include word properties" <checkbox> gadget,
+    deploy-c-types? get "Include C types" <checkbox> gadget, ;
+
+: deploy-settings-theme
+    { 10 10 } over set-pack-gap
+    1 swap set-pack-fill ;
+
+: <deploy-settings> ( -- control )
+    default-config [ <model> ] assoc-map [
+        [
+            bundle-name
+            exit-when-windows-closed
+            io-settings
+            reflection-settings
+            advanced-settings
+        ] make-pile dup deploy-settings-theme
+        namespace <mapping> swap [ 2drop ] <control>
+    ] bind ;
+
+: find-deploy-gadget
+    [ deploy-gadget? ] find-parent ;
+
+: find-deploy-vocab
+    find-deploy-gadget deploy-gadget-vocab ;
+
+: find-deploy-config
+    find-deploy-vocab deploy-config ;
+
+: find-deploy-settings
+    find-deploy-gadget deploy-gadget-settings ;
+
+: com-revert ( gadget -- )
+    dup find-deploy-config
+    swap find-deploy-settings set-control-value ;
+
+: com-save ( gadget -- )
+    dup find-deploy-settings control-value
+    swap find-deploy-vocab set-deploy-config ;
+
+: com-deploy ( gadget -- )
+    dup com-save
+    find-deploy-vocab [ deploy.app ] curry call-listener ;
+
+deploy-gadget "toolbar" f {
+    { f com-revert }
+    { f com-save }
+    { T{ key-down f f "RETURN" } com-deploy }
+} define-command-map
+
+: <deploy-gadget> ( vocab -- gadget )
+    dup f deploy-gadget construct-boa [
+        <deploy-settings>
+        g-> set-deploy-gadget-settings
+        10 <border> 1 track,
+        toolbar,
+    ] { 0 1 } build-track dup com-revert ;
+
+: deploy-tool ( vocab -- )
+    vocab-name dup <deploy-gadget>
+    "Deploying \"" rot "\"" 3append open-window ;

extra/ui/tools/operations/operations.factor

@@ -7,7 +7,8 @@ help.topics inference inspector io.files io.styles kernel
 namespaces parser prettyprint quotations tools.annotations
 editors tools.profiler tools.test tools.time tools.walker
 ui.commands ui.gadgets.editors ui.gestures ui.operations vocabs
-vocabs.loader words sequences tools.browser classes ;
+vocabs.loader words sequences tools.browser classes
+ui.tools.deploy ;
 IN: ui.tools.operations
 
 V{ } clone operations set-global
@@ -155,6 +156,8 @@ M: word com-stack-effect word-def com-stack-effect ;
     { +listener+ t }
 } define-operation
 
+[ vocab-spec? ] \ deploy-tool H{ } define-operation
+
 ! Quotations
 [ quotation? ] \ com-stack-effect H{
     { +keyboard+ T{ key-down f { C+ } "i" } }