extra/build-from-source/build-from-source.factor

   1 ! Copyright (C) 2023 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: ascii cli.git combinators.short-circuit formatting
   4 http.client io.directories io.files io.files.info io.files.temp
   5 io.launcher io.pathnames kernel layouts namespaces sequences
   6 splitting system ;
   7 IN: build-from-source
   8
   9 : dll-out-directory ( -- path )
  10     vm-path parent-directory cell-bits "dlls%s-out" sprintf append-path
  11     dup make-directories ;
  12
  13 : remake-directory ( path -- )
  14     [ ?delete-tree ] [ make-directories ] bi ;
  15
  16 : prepend-current-path ( path -- path' )
  17     current-directory get prepend-path ;
  18
  19 : find-dlls ( path -- paths )
  20     recursive-directory-files
  21     [ file-name >lower ".dll" tail? ] filter ;
  22
  23 ERROR: no-output-file path ;
  24 : copy-output-file-as ( name new-name -- )
  25     [ prepend-current-path dup file-exists? [ no-output-file ] unless ]
  26     [ dll-out-directory prepend-path ] bi* copy-file ;
  27
  28 : copy-vm-file-as ( name new-name -- )
  29     [ prepend-current-path ]
  30     [ vm-path parent-directory prepend-path ] bi* copy-file ;
  31
  32 : copy-output-file ( name -- )
  33     prepend-current-path dll-out-directory copy-file-into ;
  34
  35 : copy-output-files ( seq -- )
  36     [ copy-output-file ] each ;
  37
  38 : with-build-directory-as ( name quot -- )
  39     [ prepend-current-path dup remake-directory ] dip with-directory ; inline
  40
  41 : with-build-directory ( quot -- ) [ "build" ] dip with-build-directory-as ; inline
  42
  43 : empty-directory? ( path -- ? )
  44     { [ directory? ] [ directory-files empty? ] } 1&& ;
  45
  46 ! Windows clears the Factor temp directory but leaves the directory names (?)
  47 ! C:\Users\sheeple\AppData\Local\Temp\factorcode.org\Factor>
  48 : ?sync-repository-as ( url path -- )
  49     dup { [ git-directory? ] [ ".git" append-path empty-directory? not ] } 1&&
  50     [ dup ?delete-tree ] unless
  51     sync-repository-as wait-for-success ;
  52
  53 : with-updated-git-repo-as ( git-uri path quot -- )
  54     '[
  55         _ _ [ ?sync-repository-as ] keep
  56         prepend-current-path _ with-directory
  57     ] with-temp-directory ; inline
  58
  59 : with-updated-git-repo ( git-uri quot -- )
  60     [ dup git-directory-name ] dip with-updated-git-repo-as ; inline
  61
  62 : ?download ( path -- )
  63     dup file-name file-exists? [ drop ] [ download ] if ; inline
  64
  65 : with-tar-gz ( path quot -- )
  66     '[
  67         _
  68         [ ?download ]
  69         [ file-name { "tar" "xvfz" } swap suffix try-process ]
  70         [ file-name ".tar.gz" ?tail drop ] tri
  71         prepend-current-path _ with-directory
  72     ] with-temp-directory ; inline