Improved deploy tool caches staging images
parent
cb0d1561c7
commit
b0dcb68f70
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue