Improved deploy tool caches staging images

extra/tools/deploy/backend/backend.factor

@@ -9,50 +9,77 @@ quotations io.launcher words.private tools.deploy.config
 bootstrap.image ;
 IN: tools.deploy.backend
 
-: boot-image-name ( -- string )
-    "boot." my-arch ".image" 3append ;
-
-: stage1 ( -- )
-    #! If stage1 image doesn't exist, create one.
-    boot-image-name resource-path exists?
-    [ my-arch make-image ] unless ;
-
 : (copy-lines) ( stream -- stream )
     dup stream-readln [ print flush (copy-lines) ] when* ;
 
 : copy-lines ( stream -- )
     [ (copy-lines) ] [ stream-close ] [ ] cleanup ;
 
-: ?append swap [ append ] [ drop ] if ;
+: run-with-output ( descriptor -- )
+    <process-stream>
+    dup duplex-stream-out stream-close
+    copy-lines ;
 
-: profile-string ( config -- string )
+: boot-image-name ( -- string )
+    "boot." my-arch ".image" 3append ;
+
+: make-boot-image ( -- )
+    #! If stage1 image doesn't exist, create one.
+    boot-image-name resource-path exists?
+    [ my-arch make-image ] unless ;
+
+: ?, [ , ] [ drop ] if ;
+
+: bootstrap-profile ( config -- profile )
     [
-        ""
-        deploy-math? get " math" ?append
-        deploy-compiler? get " compiler" ?append
-        deploy-ui? get " ui" ?append
-        native-io? " io" ?append
+        [
+            "math" deploy-math? get ?,
+            "compiler" deploy-compiler? get ?,
+            "ui" deploy-ui? get ?,
+            "io" native-io? ?,
+        ] { } make
     ] bind ;
 
-: deploy-command-line ( vm image vocab config -- vm flags )
+: staging-image-name ( profile -- name )
+    "staging." swap bootstrap-profile "-" join ".image" 3append ;
+
+: staging-command-line ( config -- flags )
     [
-        "-include=" swap profile-string append ,
+        "-i=" boot-image-name append ,
 
-        "-deploy-vocab=" swap append ,
+        "-output-image=" over staging-image-name append ,
 
-        "-output-image=" swap append ,
+        "-include=" swap bootstrap-profile " " join append ,
 
         "-no-stack-traces" ,
 
         "-no-user-init" ,
     ] { } make ;
 
-: stage2 ( vm image vocab config -- )
-    deploy-command-line
-    >r "-i=" boot-image-name append 2array r> append dup .
-    <process-stream>
-    dup duplex-stream-out stream-close
-    copy-lines ;
+: run-factor ( vm flags -- )
+    dup . swap add* run-with-output ; inline
+
+: make-staging-image ( vm config -- )
+    staging-command-line run-factor ;
+
+: deploy-command-line ( image vocab config -- flags )
+    [
+        "-i=" swap staging-image-name append ,
+
+        "-run=tools.deploy.shaker" ,
+
+        "-deploy-vocab=" swap append ,
+
+        "-output-image=" swap append ,
+
+        "-no-stack-traces" ,
+    ] { } make ;
+
+: make-deploy-image ( vm image vocab config -- )
+    dup staging-image-name exists? [
+        >r pick r> tuck make-staging-image
+    ] unless
+    deploy-command-line run-factor ;
 
 SYMBOL: deploy-implementation
 

extra/tools/deploy/macosx/macosx.factor

@@ -72,13 +72,12 @@ T{ macosx-deploy-implementation } deploy-implementation set-global
     -> selectFile:inFileViewerRootedAtPath: drop ;
 
 M: macosx-deploy-implementation deploy* ( vocab -- )
-    stage1
     ".app deploy tool" assert.app
     "." resource-path cd
     dup deploy-config [
         bundle-name rm
         [ bundle-name create-app-dir ] keep
         [ bundle-name deploy.app-image ] keep
-        namespace stage2
+        namespace make-deploy-image
         bundle-name show-in-finder
     ] bind ;

extra/tools/deploy/windows/windows.factor

@@ -34,11 +34,10 @@ TUPLE: windows-deploy-implementation ;
 T{ windows-deploy-implementation } deploy-implementation set-global
 
 M: windows-deploy-implementation deploy*
-    stage1
     "." resource-path cd
     dup deploy-config [
         [ deploy-name get create-exe-dir ] keep
         [ deploy-name get image-name ] keep
-        [ namespace stage2 ] keep
+        [ namespace make-deploy-image ] keep
         open-in-explorer
     ] bind ;