extra/zealot/factor/factor.factor

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