builder: more refactoring

extra/builder/build/build.factor

@@ -0,0 +1,46 @@
+
+USING: io.files io.launcher io.encodings.utf8 prettyprint
+       builder.util builder.common builder.child builder.release
+       builder.report builder.email builder.cleanup ;
+
+IN: builder.build
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: create-build-dir ( -- )
+  datestamp >stamp
+  build-dir make-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: enter-build-dir  ( -- ) build-dir set-current-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clone-builds-factor ( -- )
+  { "git" "clone" builds/factor } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-id ( -- )
+  "factor"
+    [ git-id "../git-id" utf8 [ . ] with-file-writer ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: build ( -- )
+  reset-status
+  create-build-dir
+  enter-build-dir
+  clone-builds-factor
+  record-id
+  build-child
+  release
+  report
+  email-report
+  cleanup ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: build

extra/builder/builder.factor

@@ -1,259 +1,21 @@
 
-USING: kernel namespaces sequences splitting system combinators continuations
+USING: kernel debugger io.files threads calendar 
-       parser io io.files io.launcher io.sockets prettyprint threads
-       bootstrap.image benchmark vars bake smtp builder.util accessors
-       debugger io.encodings.utf8
-       calendar
-       tools.test
        builder.common
-       builder.benchmark
+       builder.updates
-       builder.release ;
+       builder.build ;
 
 IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: cd ( path -- ) set-current-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds/factor ( -- path ) builds "factor" append-path ;
-: build-dir     ( -- path ) builds stamp>   append-path ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prepare-build-machine ( -- )
-  builds make-directory
-  builds
-    [
-      { "git" "clone" "git://factorcode.org/git/factor.git" } try-process
-    ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: enter-build-dir ( -- )
-  datestamp >stamp
-  builds cd
-  stamp> make-directory
-  stamp> cd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-id ( -- id )
-  { "git" "show" } utf8 <process-stream>
-  [ readln ] with-stream " " split second ;
-
-: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gnu-make ( -- string )
-  os { freebsd openbsd netbsd } member?
-    [ "gmake" ]
-    [ "make"  ]
-  if ;
-
-: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-vm ( -- desc )
-  <process>
-    { gnu-make } to-strings >>command
-    "../compile-log"        >>stdout
-    +stdout+                >>stderr ;
-
-: do-make-vm ( -- )
-  make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-image ( -- )
-  builds/factor my-boot-image-name append-path ".." copy-file-into
-  builds/factor my-boot-image-name append-path "."  copy-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bootstrap-cmd ( -- cmd )
-  { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-
-: bootstrap ( -- desc )
-  <process>
-    bootstrap-cmd >>command
-    +closed+      >>stdin
-    "../boot-log" >>stdout
-    +stdout+      >>stderr
-    60 minutes    >>timeout ;
-
-: do-bootstrap ( -- )
-  bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
-
-: builder-test-cmd ( -- cmd )
-  { "./factor" "-run=builder.test" } to-strings ;
-
-: builder-test ( -- desc )
-  <process>
-    builder-test-cmd >>command
-    +closed+         >>stdin
-    "../test-log"    >>stdout
-    +stdout+         >>stderr
-    240 minutes      >>timeout ;
-
-: do-builder-test ( -- )
-  builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: build-status
-
-: (build) ( -- )
-
-  builds-check  
-
-  build-status off
-
-  enter-build-dir
-
-  "report" utf8
-    [
-      "Build machine:   " write host-name             print
-      "CPU:             " write cpu                   .
-      "OS:              " write os                    .
-      "Build directory: " write current-directory get print
-
-      git-clone [ "git clone failed" print ] run-or-bail
-
-      "factor"
-        [
-          record-git-id
-          do-make-clean
-          do-make-vm
-          copy-image
-          do-bootstrap
-          do-builder-test
-        ]
-      with-directory
-
-      "test-log" delete-file
-
-      "git id:          " write "git-id" eval-file print nl
-
-      "Boot time: " write "boot-time" eval-file milli-seconds>time print
-      "Load time: " write "load-time" eval-file milli-seconds>time print
-      "Test time: " write "test-time" eval-file milli-seconds>time print nl
-
-      "Did not pass load-everything: " print "load-everything-vocabs" cat
-      
-      "Did not pass test-all: "        print "test-all-vocabs"        cat
-                                             "test-failures"          cat
-      
-      "help-lint results:"             print "help-lint"              cat
-
-      "Benchmarks: " print "benchmarks" eval-file benchmarks.
-
-      nl
-
-      show-benchmark-deltas
-
-      "benchmarks" ".." copy-file-into
-
-      release
-    ]
-  with-file-writer
-
-  build-status on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-from
-
-SYMBOL: builder-recipients
-
-: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
-
-: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
-
-: send-builder-email ( -- )
-  <email>
-    builder-from get        >>from
-    builder-recipients get  >>to
-    subject                 >>subject
-    "./report" file>string >>body
-  send-email ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
-
-! : build ( -- )
-!   [ (build) ] try
-!   builds cd stamp> cd
-!   [ send-builder-email ] try
-!   { "rm" "-rf" "factor" } [ ] run-or-bail
-!   [ compress-image ] try ;
-
-: build ( -- )
-  [
-    (build)
-    build-dir
-      [
-        { "rm" "-rf" "factor" } try-process
-        compress-image
-      ]
-    with-directory
-  ]
-  try
-  send-builder-email ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: bootstrap.image.download
-
-: git-pull ( -- desc )
-  {
-    "git"
-    "pull"
-    "--no-summary"
-    "git://factorcode.org/git/factor.git"
-    "master"
-  } ;
-
-: updates-available? ( -- ? )
-  git-id
-  git-pull try-process
-  git-id
-  = not ;
-
-: new-image-available? ( -- ? )
-  my-boot-image-name need-new-image?
-    [ download-my-image t ]
-    [ f ]
-  if ;
-
 : build-loop ( -- )
   builds-check
   [
-    builds/factor
+    builds/factor set-current-directory
-      [
+    new-code-available? [ build ] when
-        updates-available? new-image-available? or
-          [ build ]
-        when
-      ]
-    with-directory
   ]
   try
   5 minutes sleep
   build-loop ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+MAIN: build-loop
-
-MAIN: build-loop

extra/builder/child/child.factor

@@ -0,0 +1,70 @@
+
+USING: namespaces debugger io.files io.launcher accessors bootstrap.image
+       calendar builder.util builder.common ;
+
+IN: builder.child
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-vm ( -- )
+  <process>
+    gnu-make         >>command
+    "../compile-log" >>stdout
+    +stdout+         >>stderr
+  try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
+
+: copy-image ( -- )
+  builds-factor-image ".." copy-file-into
+  builds-factor-image "."  copy-file-into ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boot-cmd ( -- cmd )
+  { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
+
+: boot ( -- )
+  <process>
+    boot-cmd      >>command
+    +closed+      >>stdin
+    "../boot-log" >>stdout
+    +stdout+      >>stderr
+    60 minutes    >>timeout
+  try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
+
+: test ( -- )
+  <process>
+    test-cmd      >>command
+    +closed+      >>stdin
+    "../test-log" >>stdout
+    +stdout+      >>stderr
+    240 minutes   >>timeout
+  try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (build-child) ( -- )
+  make-clean
+  make-vm      status-vm   on
+  copy-image
+  boot         status-boot on
+  test         status-test on
+               status      on ;
+
+! : build-child ( -- ) "factor" [ (build-child) ] with-directory ;
+
+: build-child ( -- )
+  "factor" set-current-directory
+    [ (build-child) ] try
+  ".." set-current-directory ;

extra/builder/cleanup/cleanup.factor

@@ -0,0 +1,24 @@
+
+USING: kernel namespaces io.files io.launcher bootstrap.image
+       builder.util builder.common ;
+
+IN: builder.cleanup
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-debug
+
+: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
+
+: delete-child-factor ( -- )
+  build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
+
+: cleanup ( -- )
+  builder-debug get f =
+    [
+      "test-log" delete-file
+      delete-child-factor
+      compress-image
+    ]
+  when ;
+

extra/builder/common/common.factor

@@ -1,5 +1,7 @@
 
-USING: kernel namespaces io.files sequences vars ;
+USING: kernel namespaces sequences splitting
+       io io.files io.launcher io.encodings.utf8 prettyprint
+       vars builder.util ;
 
 IN: builder.common
 
@@ -16,4 +18,47 @@ SYMBOL: builds-dir
 
 VAR: stamp
 
-SYMBOL: upload-to-factorcode
+: builds/factor ( -- path ) builds "factor" append-path ;
+: build-dir     ( -- path ) builds stamp>   append-path ;
+
+: create-build-dir ( -- )
+  datestamp >stamp
+  build-dir make-directory ;
+  
+: enter-build-dir  ( -- ) build-dir set-current-directory ;
+
+: clone-builds-factor ( -- )
+  { "git" "clone" builds/factor } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prepare-build-machine ( -- )
+  builds make-directory
+  builds
+    [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: status-vm
+SYMBOL: status-boot
+SYMBOL: status-test
+SYMBOL: status-build
+SYMBOL: status-release
+SYMBOL: status
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: reset-status ( -- )
+  { status-vm status-boot status-test status-build status-release status }
+    [ off ]
+  each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: upload-to-factorcode
+

extra/builder/email/email.factor

@@ -0,0 +1,22 @@
+
+USING: kernel namespaces accessors smtp builder.util builder.common ;
+
+IN: builder.email
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-from
+SYMBOL: builder-recipients
+
+: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
+
+: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
+
+: email-report ( -- )
+  <email>
+    builder-from get       >>from
+    builder-recipients get >>to
+    subject                >>subject
+    "report" file>string   >>body
+  send-email ;
+

extra/builder/release/branch/branch.factor

@@ -36,5 +36,5 @@ IN: builder.release.branch
 
 : update-clean-branch ( -- )
   upload-to-factorcode get
-    [ update-clean-branch ]
+    [ (update-clean-branch) ]
   when ;

extra/builder/release/release.factor

@@ -1,5 +1,5 @@
 
-USING: kernel system namespaces sequences splitting combinators
+USING: kernel debugger system namespaces sequences splitting combinators
        io io.files io.launcher prettyprint bootstrap.image
        bake combinators.cleave
        builder.util
@@ -18,9 +18,10 @@ IN: builder.release
   tidy
   make-archive
   upload
-  save-archive ;
+  save-archive
+  status-release on ;
 
 : clean-build? ( -- ? )
   { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
 
-: release ( -- ) clean-build? [ (release) ] when ;
+: release ( -- ) [ clean-build? [ (release) ] when ] try ;

extra/builder/report/report.factor

@@ -0,0 +1,35 @@
+
+USING: kernel namespaces debugger system io io.files io.sockets
+       io.encodings.utf8 prettyprint benchmark
+       builder.util builder.common ;
+
+IN: builder.report
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (report) ( -- )
+
+  "Build machine:   " write host-name             print
+  "CPU:             " write cpu                   .
+  "OS:              " write os                    .
+  "Build directory: " write build-dir             print
+  "git id:          " write "git-id" eval-file    print nl
+
+  status-vm   get f = [ "compile-log" cat    "vm compile error" throw ] when
+  status-boot get f = [ "boot-log"    cat    "Boot error"       throw ] when
+  status-test get f = [ "test-log" 100 cat-n "Test error"       throw ] when
+
+  "Boot time: " write "boot-time" eval-file milli-seconds>time print
+  "Load time: " write "load-time" eval-file milli-seconds>time print
+  "Test time: " write "test-time" eval-file milli-seconds>time print nl
+
+  "Did not pass load-everything: " print "load-everything-vocabs" cat
+      
+  "Did not pass test-all: "        print "test-all-vocabs"        cat
+                                         "test-failures"          cat
+      
+  "help-lint results:"             print "help-lint"              cat
+
+  "Benchmarks: " print "benchmarks" eval-file benchmarks. ;
+
+: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;

extra/builder/updates/updates.factor

@@ -0,0 +1,31 @@
+
+USING: kernel io.launcher bootstrap.image bootstrap.image.download
+       builder.util builder.common ;
+
+IN: builder.updates
+
+: git-pull-cmd ( -- cmd )
+  {
+    "git"
+    "pull"
+    "--no-summary"
+    "git://factorcode.org/git/factor.git"
+    "master"
+  } ;
+
+: updates-available? ( -- ? )
+  git-id
+  git-pull-cmd try-process
+  git-id
+  = not ;
+
+: new-image-available? ( -- ? )
+  my-boot-image-name need-new-image?
+    [ download-my-image t ]
+    [ f ]
+  if ;
+
+: new-code-available? ( -- ? )
+  updates-available?
+  new-image-available?
+  or ;

extra/builder/util/util.factor

@@ -25,11 +25,11 @@ DEFER: to-strings
 : to-string ( obj -- str )
   dup class
     {
-      { string    [ ] }
+      { \ string    [ ] }
-      { quotation [ call ] }
+      { \ quotation [ call ] }
-      { word      [ execute ] }
+      { \ word      [ execute ] }
-      { fixnum    [ number>string ] }
+      { \ fixnum    [ number>string ] }
-      { array     [ to-strings concat ] }
+      { \ array     [ to-strings concat ] }
     }
   case ;
 
@@ -97,4 +97,15 @@ USE: prettyprint
 
 : cpu- ( -- cpu ) cpu unparse "." split "-" join ;
 
-: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+  os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-id ( -- id )
+  { "git" "show" } utf8 <process-stream> [ readln ] with-stream
+  " " split second ;