basis/tools/deploy/backend/backend.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make continuations.private kernel.private init
   4 assocs kernel vocabs words sequences memory io system arrays
   5 continuations math definitions mirrors splitting parser classes
   6 summary layouts vocabs.loader prettyprint.config prettyprint debugger
   7 io.streams.c io.files io.files.temp io.pathnames io.directories
   8 io.directories.hierarchy io.backend quotations io.launcher
   9 tools.deploy.config tools.deploy.config.editor bootstrap.image
  10 io.encodings.utf8 destructors accessors hashtables ;
  11 IN: tools.deploy.backend
  12
  13 : copy-vm ( executable bundle-name -- vm )
  14     prepend-path vm over copy-file ;
  15
  16 CONSTANT: theme-path "basis/ui/gadgets/theme/"
  17
  18 : copy-theme ( name dir -- )
  19     deploy-ui? get [
  20         append-path
  21         theme-path append-path
  22         [ make-directories ]
  23         [ theme-path "resource:" prepend swap copy-tree ] bi
  24     ] [ 2drop ] if ;
  25
  26 : image-name ( vocab bundle-name -- str )
  27     prepend-path ".image" append ;
  28
  29 : copy-lines ( -- )
  30     readln [ print flush copy-lines ] when* ;
  31
  32 : run-with-output ( arguments -- )
  33     <process>
  34         swap >>command
  35         +stdout+ >>stderr
  36         +closed+ >>stdin
  37         +low-priority+ >>priority
  38     utf8 [ copy-lines ] with-process-reader ;
  39
  40 : make-boot-image ( -- )
  41     #! If stage1 image doesn't exist, create one.
  42     my-boot-image-name resource-path exists?
  43     [ my-arch make-image ] unless ;
  44
  45 : bootstrap-profile ( -- profile )
  46     [
  47         deploy-math? get [ "math" , ] when
  48         deploy-threads? get [ "threads" , ] when
  49         "compiler" ,
  50         deploy-ui? get [ "ui" , ] when
  51         deploy-unicode? get [ "unicode" , ] when
  52         native-io? [ "io" , ] when
  53     ] { } make ;
  54
  55 : staging-image-name ( profile -- name )
  56     "-" join "staging." ".image" surround temp-file ;
  57
  58 DEFER: ?make-staging-image
  59
  60 : staging-command-line ( profile -- flags )
  61     [
  62         "-staging" ,
  63         dup empty? [
  64             "-i=" my-boot-image-name append ,
  65         ] [
  66             dup but-last ?make-staging-image
  67             "-resource-path=" "" resource-path append ,
  68             "-i=" over but-last staging-image-name append ,
  69             "-run=tools.deploy.restage" ,
  70         ] if
  71         "-output-image=" over staging-image-name append ,
  72         "-include=" swap " " join append ,
  73         "-no-user-init" ,
  74     ] { } make ;
  75
  76 : run-factor ( vm flags -- )
  77     swap prefix dup . run-with-output ; inline
  78
  79 : make-staging-image ( profile -- )
  80     vm swap staging-command-line run-factor ;
  81
  82 : ?make-staging-image ( profile -- )
  83     dup staging-image-name exists?
  84     [ drop ] [ make-staging-image ] if ;
  85
  86 : make-deploy-config ( vocab -- file )
  87     [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
  88     [ "deploy-config-" prepend temp-file ] bi
  89     [ utf8 set-file-contents ] keep ;
  90
  91 : deploy-command-line ( image vocab config -- flags )
  92     [
  93         bootstrap-profile ?make-staging-image
  94
  95         [
  96             "-i=" bootstrap-profile staging-image-name append ,
  97             "-resource-path=" "" resource-path append ,
  98             "-run=tools.deploy.shaker" ,
  99             [ "-deploy-vocab=" prepend , ]
 100             [ make-deploy-config "-deploy-config=" prepend , ] bi
 101             "-output-image=" prepend ,
 102         ] { } make
 103     ] bind ;
 104
 105 : make-deploy-image ( vm image vocab config -- )
 106     make-boot-image
 107     deploy-command-line run-factor ;
 108
 109 HOOK: deploy* os ( vocab -- )