extra/zealot/factor/factor.factor

   1 ! Copyright (C) 2017 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs bootstrap.image calendar cli.git
   4 combinators concurrency.combinators environment formatting
   5 http.client io io.directories io.launcher io.pathnames kernel
   6 math.parser memory modern.paths namespaces parser.notes
   7 prettyprint sequences sequences.extras sets splitting system
   8 system-info threads tools.test tools.test.private vocabs
   9 vocabs.hierarchy vocabs.hierarchy.private vocabs.loader
  10 vocabs.metadata zealot ;
  11 IN: zealot.factor
  12
  13 : download-boot-checksums ( path branch -- )
  14     '[ _ "http://downloads.factorcode.org/images/%s/checksums.txt" sprintf download ] with-directory ;
  15
  16 : download-boot-image ( path branch image-name -- )
  17     '[ _ _ "http://downloads.factorcode.org/images/%s/%s" sprintf download ] with-directory ;
  18
  19 : download-my-boot-image ( path branch -- )
  20     my-boot-image-name download-boot-image ;
  21
  22 HOOK: compile-factor-command os ( -- array )
  23 M: unix compile-factor-command ( -- array )
  24     { "make" "-j" } cpus number>string suffix ;
  25 M: windows compile-factor-command ( -- array )
  26     { "nmake" "/f" "NMakefile" "x86-64" } ;
  27
  28 HOOK: factor-path os ( -- path )
  29 M: unix factor-path "./factor" ;
  30 M: windows factor-path "./factor.com" ;
  31
  32 : compile-factor ( path -- )
  33     [
  34         <process>
  35             compile-factor-command >>command
  36             "./compile-log" >>stdout
  37             +stdout+ >>stderr
  38             +new-group+ >>group
  39         try-process
  40     ] with-directory ;
  41
  42 : bootstrap-factor ( path -- )
  43     [
  44         <process>
  45             factor-path "-i=" my-boot-image-name append "-no-user-init" 3array >>command
  46             +closed+ >>stdin
  47             "./bootstrap-log" >>stdout
  48             +stdout+ >>stderr
  49             30 minutes >>timeout
  50             +new-group+ >>group
  51         try-process
  52     ] with-directory ;
  53
  54 ! Meant to run in the child process
  55 : with-child-options ( quot -- )
  56     f parser-quiet? set-global
  57     f restartable-tests? set-global
  58     f long-unit-tests-enabled? set-global
  59     call ; inline
  60
  61 : zealot-load-and-save ( vocabs path -- )
  62     dup "load-and-save to " prepend print flush yield
  63     '[
  64         [ load ] each _ save-image
  65     ] with-child-options ;
  66
  67 : zealot-load-basis ( -- ) basis-vocabs "factor.image.basis" zealot-load-and-save ;
  68 : zealot-load-extra ( -- ) extra-vocabs "factor.image.extra" zealot-load-and-save ;
  69
  70 ! like ``"" load`` -- only platform-friendly vocabs
  71 : zealot-vocabs-from-root ( root -- seq ) "" vocabs-to-load [ vocab-name ] map ;
  72 : zealot-all-vocabs ( -- seq ) vocab-roots get [ zealot-vocabs-from-root ] map-concat ;
  73 : zealot-core-vocabs ( -- seq ) "resource:core" zealot-vocabs-from-root ;
  74 : zealot-basis-vocabs ( -- seq ) "resource:basis" zealot-vocabs-from-root ;
  75 : zealot-extra-vocabs ( -- seq ) "resource:extra" zealot-vocabs-from-root ;
  76
  77 : zealot-load-all ( -- ) zealot-all-vocabs "factor.image.all" zealot-load-and-save ;
  78
  79 : zealot-load-command ( command log-path -- process )
  80     <process>
  81         swap >>stdout
  82         swap >>command
  83         +closed+ >>stdin
  84         +stdout+ >>stderr
  85         60 minutes >>timeout
  86         +new-group+ >>group ;
  87
  88 : zealot-load-basis-command ( -- process )
  89     factor-path "-e=USE: zealot.factor zealot-load-basis" 2array
  90     "./load-basis-log" zealot-load-command ;
  91
  92 : zealot-load-extra-command ( -- process )
  93     factor-path "-e=USE: zealot.factor zealot-load-extra" 2array
  94     "./load-extra-log" zealot-load-command ;
  95
  96 : zealot-load-commands ( path -- )
  97     [
  98         zealot-load-basis-command
  99         zealot-load-extra-command 2array
 100         [ try-process ] parallel-each
 101     ] with-directory ;
 102
 103 : zealot-test-command ( command log-path -- process )
 104     <process>
 105         swap >>stdout
 106         swap >>command
 107         +closed+ >>stdin
 108         +stdout+ >>stderr
 109         60 minutes >>timeout
 110         +new-group+ >>group ;
 111
 112 : zealot-load-and-test ( vocabs -- )
 113     '[
 114         _ [ [ load ] each ] [ test-vocabs ] bi
 115     ] with-child-options ;
 116
 117 : load-and-test-command ( i -- command )
 118     [
 119         factor-path
 120         "-i=factor.image"
 121     ] dip
 122     [
 123         "-e=USING: zealot.factor tools.test grouping.extras formatting ; [ %d all-zealot-vocabs 32 n-groups nth zealot-load-and-test ] with-child-options"
 124         sprintf 3array
 125     ] [ "./test-%d-log" sprintf ] bi
 126
 127     <process>
 128         swap >>stdout
 129         swap >>command
 130         +closed+ >>stdin
 131         +stdout+ >>stderr
 132         60 minutes >>timeout
 133         +new-group+ >>group ;
 134
 135 : zealot-test-commands ( path -- )
 136      [
 137         32 <iota> [
 138              load-and-test-command
 139         ] map [ try-process ] parallel-each
 140      ] with-directory ;
 141
 142 : zealot-test-commands-old ( path -- )
 143     [
 144         factor-path "-i=factor.image" "-e=USE: zealot.factor USE: tools.test [ zealot-core-vocabs test-vocabs ] with-child-options" 3array
 145         "./test-core-log" zealot-test-command
 146
 147         factor-path "-i=factor.image.basis" "-e=USE: zealot.factor USE: tools.test [ zealot-basis-vocabs test-vocabs ] with-child-options" 3array
 148         "./test-basis-log" zealot-test-command
 149
 150         factor-path "-i=factor.image.extra" "-e=USE: zealot.factor USE: tools.test [ zealot-extra-vocabs test-vocabs ] with-child-options" 3array
 151         "./test-extra-log" zealot-test-command 3array
 152
 153         [ try-process ] parallel-each
 154     ] with-directory ;
 155
 156 : build-new-factor ( branch -- )
 157     "factor" "factor" zealot-github-ensure drop
 158
 159     [ "factor" "factor" zealot-github-clone-paths nip ] dip
 160     over <pathname> . flush yield
 161     {
 162         [ drop "factor" "factor" zealot-github-add-build-remote drop ]
 163         [ drop [ git-fetch-all* ] with-directory drop ]
 164         [ zealot-build-checkout-branch drop ]
 165         [ "ZEALOT DOWNLOADING BOOT IMAGE" print flush download-my-boot-image ]
 166         [ "ZEALOT DOWNLOADING CHECKSUMS" print flush download-boot-checksums ]
 167         [ "ZEALOT COMPILING" print flush drop compile-factor ]
 168         [ "ZEALOT BOOTSTRAPPING" print flush drop bootstrap-factor ]
 169         [ "ZEALOT LOADING ROOTS" print flush drop zealot-load-commands ]
 170         [ "ZEALOT TESTING ROOTS" print flush drop zealot-test-commands ]
 171     } 2cleave ;
 172
 173 : factor-clean-branch ( -- str )
 174     os cpu [ name>> ] bi@ { { CHAR: . CHAR: - } } substitute
 175     "-" glue "origin/clean-" prepend ;
 176
 177 : vocab-path>vocab ( path -- vocab )
 178     [ parent-directory ] map
 179     [ "/" split1 nip ] map
 180     [ path-separator split harvest "." join ] map ;
 181
 182 : changed-factor-vocabs ( old-rev new-rev -- vocabs )
 183     [
 184         default-vocab-roots
 185         [ ":" split1 nip ] map
 186         [ "/" append ] map
 187     ] 2dip git-diff-name-only*
 188     [ ".factor" tail? ] filter
 189     [ swap [ head? ] with any? ] with filter
 190     [ parent-directory ] map
 191     [ "/" split1 nip ] map
 192     [ path-separator split harvest "." join ] map members ;
 193
 194 : changed-factor-vocabs-from-master ( -- vocabs )
 195     "HEAD" "origin/master" changed-factor-vocabs ;
 196
 197 : changed-factor-vocabs-from-clean ( -- vocabs )
 198     "HEAD" factor-clean-branch changed-factor-vocabs ;
 199
 200 : testing-a-branch? ( -- ? )
 201     "CI_BRANCH" os-env "master" or
 202     "master" = not ;
 203
 204 : reject-unloadable-vocabs ( vocabs -- vocabs' )
 205     [ don't-load? ] reject ;
 206
 207 ! Test changes from a CI_BRANCH against origin/master
 208 ! Test master against last clean build, e.g. origin/clean-linux-x86-64
 209 : ci-vocabs-to-test ( -- vocabs )
 210     testing-a-branch? [
 211         changed-factor-vocabs-from-master
 212     ] [
 213         changed-factor-vocabs-from-clean
 214     ] if reject-unloadable-vocabs ;