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