(zilch lang go): introduce proper vfs record
This should hopefully make the code a bit clearer, and is preparation for Rust support.
This commit is contained in:
parent
0c575ca0e4
commit
fc8aea8fb4
5 changed files with 228 additions and 162 deletions
|
|
@ -14,13 +14,60 @@
|
|||
(json)
|
||||
(chicken base) (chicken format) (chicken foreign)
|
||||
(scheme char)
|
||||
(srfi 4) (srfi 128) (srfi 133) (srfi 146) (srfi 152) (srfi 207)
|
||||
(srfi 4) (srfi 113) (srfi 128) (srfi 133) (srfi 146) (srfi 152) (srfi 207)
|
||||
(zilch lang go) (zilch lang go core) (zilch lang go stdlib) (zilch lang go sum) (zilch lang go fetch)
|
||||
(chicken foreign))
|
||||
|
||||
(export vfs-from-dirhash vfs-from-directory filter-vfs filter-vfs-for-package-reading vfs-to-store)
|
||||
(export vfs? vfs-dir-files vfs-file-ref vfs-dir-filter vfs-dir-filter-all vfs-from-dirhash vfs-from-directory vfs-filter-for-go-package vfs-to-store vfs-to-json)
|
||||
|
||||
(begin
|
||||
;; `contents` is a mapping whose keys are a pair (dir . filename) to file contents (e.g. zfile, or store path).
|
||||
;; The file contents may be the symbol 'directory to indicate there's a directory.
|
||||
;;
|
||||
;; The root directory is specified by `dir` being an empty string. There are no trailing or leading slashes.
|
||||
(define-record-type <vfs>
|
||||
(make-vfs contents)
|
||||
vfs?
|
||||
(contents vfs-contents))
|
||||
|
||||
(define (vfs-dir-files vfs dir)
|
||||
(mapping-map->list
|
||||
(lambda (k v) (cons (cdr k) v))
|
||||
(mapping-filter
|
||||
(lambda (key val)
|
||||
(and (not (eq? val 'directory)) (string=? (car key) dir)))
|
||||
(vfs-contents vfs))))
|
||||
|
||||
(define (vfs-file-ref vfs dirname filename)
|
||||
(mapping-ref/default (vfs-contents vfs) (cons dirname filename) #f))
|
||||
|
||||
;; Calls the filter with the dir, filename, and contents, for each file.
|
||||
;; If filter returns #f, the file in the vfs will be replaced by /dev/null.
|
||||
(define (vfs-dir-filter vfs filter)
|
||||
(make-vfs
|
||||
(mapping-map/monotone
|
||||
(lambda (key val)
|
||||
(if (or (eq? val 'directory) (filter (car key) (cdr key) val)) (values key val) (values key "/dev/null")))
|
||||
(make-default-comparator)
|
||||
(vfs-contents vfs))))
|
||||
|
||||
;; Calls the filter for each directory. If the filter returns #f, the directory's files are replaced with `/dev/null`.
|
||||
(define (vfs-dir-filter-all filter vfs)
|
||||
(define to-filter-out (set (make-default-comparator)))
|
||||
(mapping-for-each
|
||||
(lambda (key val)
|
||||
(when (and (eq? val 'directory) (not (filter (string-append (car key) "/" (cdr key)))))
|
||||
(set! to-filter-out (set-adjoin! to-filter-out (string-append (car key) "/" (cdr key))))))
|
||||
(vfs-contents vfs))
|
||||
(define (is-filtered dirname)
|
||||
(set-any? (lambda (v) (string=? v dirname)) to-filter-out))
|
||||
(make-vfs
|
||||
(mapping-map/monotone
|
||||
(lambda (key val)
|
||||
(if (or (eq? val 'directory) (not (is-filtered (car key)))) (values key val) (values key "/dev/null")))
|
||||
(make-default-comparator)
|
||||
(vfs-contents vfs))))
|
||||
|
||||
(define (read-full-file port)
|
||||
(define buf (make-bytevector 2048 0))
|
||||
(call-with-port (open-output-bytevector)
|
||||
|
|
@ -43,7 +90,7 @@
|
|||
(map go-stdlib-ref '("archive/zip" "io" "os"))
|
||||
(list (cons "main.go" (zfile (foreign-value "unzip_one_source" nonnull-c-string)))))))
|
||||
|
||||
(define (rewrite-name name)
|
||||
(define (rewrite-go-package-name-for-url name)
|
||||
(define out "")
|
||||
(string-for-each (lambda (ch)
|
||||
(if (char-upper-case? ch) (set! out (string-append out (string #\! (char-downcase ch)))) (set! out (string-append out (string ch))))) name)
|
||||
|
|
@ -53,30 +100,31 @@
|
|||
;; returning a zdir describing the root directory.
|
||||
(define (vfs-to-store vfs)
|
||||
(define dirmap (mapping (make-default-comparator)))
|
||||
(vector-for-each
|
||||
(lambda (pair)
|
||||
(define key (car pair))
|
||||
(define separator (if (string=? key "/") 0 (string-index-right key (lambda (ch) (char=? ch #\/)) 0 (- (string-length key) 1))))
|
||||
(unless (string=? key "/")
|
||||
(let
|
||||
((dirname (string-copy key 0 (+ 1 separator)))
|
||||
(fname (string-copy key (+ 1 separator) (- (string-length key) 1))))
|
||||
(set! dirmap (mapping-set! dirmap dirname (cons (cons fname key) (mapping-ref/default dirmap dirname '())))))))
|
||||
vfs)
|
||||
(define (translate-dir name)
|
||||
(define files (vector-any (lambda (f) (and (string=? (car f) name) (cdr f))) vfs))
|
||||
(define dirs (mapping-ref/default dirmap name '()))
|
||||
(zdir (append
|
||||
(map (lambda (kv) (cons (car kv) (zsymlink (cdr kv)))) (vector->list files))
|
||||
(map (lambda (k) (cons (car k) (translate-dir (cdr k)))) dirs))))
|
||||
(translate-dir "/"))
|
||||
(mapping-for-each
|
||||
(lambda (k contents)
|
||||
(define dir (car k))
|
||||
(define fname (cdr k))
|
||||
(unless (eq? contents 'directory)
|
||||
(set! dirmap (mapping-update!/default dirmap dir (lambda (v) (cons (cons fname (zsymlink contents)) v)) '()))))
|
||||
(vfs-contents vfs))
|
||||
(mapping-for-each
|
||||
(lambda (k contents)
|
||||
(define dir (car k))
|
||||
(define fname (cdr k))
|
||||
(when (eq? contents 'directory)
|
||||
(let*
|
||||
((name (string-append dir "/" fname))
|
||||
(dir (mapping-ref dirmap name)))
|
||||
(set! dirmap (mapping-update!/default dirmap dir (lambda (v) (cons (cons fname (zdir dir)) v)) '())))))
|
||||
(vfs-contents vfs))
|
||||
(zdir (mapping-ref/default dirmap "" '())))
|
||||
|
||||
;; Reads a dirhash from a `go.sum` line. This prefetches the module from
|
||||
;; the go module proxy, and then generates the dirhash without unpacking
|
||||
;; said module file.
|
||||
(define (fetch-dirhash-for-sum sum-line)
|
||||
(when (go-sum-path sum-line) (error "go.sum line is invalid for fetch-dirhash-for-sum" sum-line))
|
||||
(define url (string-append "https://proxy.golang.org/" (rewrite-name (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
|
||||
(define url (string-append "https://proxy.golang.org/" (rewrite-go-package-name-for-url (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
|
||||
(define known (fetch-with-known-url "module.zip" url))
|
||||
(store-path-for-fod "module" "x86_64-linux" #~(#$dirhash-generator) #~(("src" . #$known)) "sha256" (go-sum-hash sum-line) #f))
|
||||
|
||||
|
|
@ -84,7 +132,7 @@
|
|||
;; line.
|
||||
(define (vfs-from-dirhash sum-line)
|
||||
(define dirhash-file (fetch-dirhash-for-sum sum-line))
|
||||
(define url (string-append "https://proxy.golang.org/" (rewrite-name (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
|
||||
(define url (string-append "https://proxy.golang.org/" (rewrite-go-package-name-for-url (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
|
||||
(define zip (fetch-with-known-url "module.zip" url))
|
||||
(define lines '())
|
||||
(define prefix-length (string-length (string-append (go-sum-module sum-line) "@" (go-sum-version sum-line) "/")))
|
||||
|
|
@ -96,62 +144,53 @@
|
|||
(set! hash (hex-string->bytevector (string-copy line 0 64)))
|
||||
(set! file (string-copy line 66))
|
||||
(set! lines (cons (cons file hash) lines))))))
|
||||
(define dirs '())
|
||||
(define output (mapping (make-default-comparator)))
|
||||
(for-each
|
||||
; (path . hash)
|
||||
(lambda (pair)
|
||||
(define fpath (string-copy (car pair) prefix-length))
|
||||
(define slashindex (string-index-right fpath (lambda (c) (char=? c #\/))))
|
||||
(define dirname "/")
|
||||
(define filename fpath)
|
||||
(when slashindex
|
||||
(set! dirname (string-append "/" (string-copy fpath 0 slashindex) "/"))
|
||||
(set! filename (string-copy fpath (+ slashindex 1))))
|
||||
(define file-path (string-copy (car pair) prefix-length))
|
||||
(define hash (cdr pair))
|
||||
|
||||
(define dir (assoc dirname dirs))
|
||||
(define file (store-path-for-fod "file" "x86_64-linux" #~(#$unpack-zip #$zip ,(car pair)) '() "sha256" (cdr pair) #f))
|
||||
(unless dir
|
||||
(set! dirs (cons (list dirname) dirs))
|
||||
(set! dir (car dirs)))
|
||||
(define last-slash (string-index-right file-path (lambda (c) (char=? c #\/))))
|
||||
(define dirname "")
|
||||
(define filename file-path)
|
||||
(when last-slash
|
||||
(set! dirname (string-copy file-path 0 last-slash))
|
||||
(set! filename (string-copy file-path (+ last-slash 1))))
|
||||
|
||||
; Record directory name in the parent directory.
|
||||
(unless last-slash
|
||||
(let ((second-to-last-slash (string-index-right dirname (lambda (c) (char=? c #\/)))))
|
||||
(if second-to-last-slash
|
||||
(set! output (mapping-set! output (cons (string-copy dirname 0 second-to-last-slash) (string-copy dirname (+ second-to-last-slash 1))) 'directory))
|
||||
(unless (string=? dirname "") (set! output (mapping-set! output (cons "" dirname) 'directory))))))
|
||||
|
||||
(define file (store-path-for-fod "file" "x86_64-linux" #~(#$unpack-zip #$zip ,(car pair)) '() "sha256" hash #f))
|
||||
|
||||
; Skip files we know for sure won't be used.
|
||||
; TODO(puck): this should be moved to vfs-filter-for-go-package?
|
||||
(unless (or (string-contains dirname "/_") (string-contains dirname "/.") (string-contains dirname "/testdata/") (char=? #\. (string-ref filename 0)) (char=? #\_ (string-ref filename 0)))
|
||||
(set-cdr! dir (cons (cons filename file) (cdr dir)))))
|
||||
(set! output (mapping-set! output (cons dirname filename) file))))
|
||||
lines)
|
||||
(list->vector (map (lambda (pair) (cons (car pair) (list->vector (cdr pair)))) dirs)))
|
||||
(make-vfs output))
|
||||
|
||||
;; Generates a full VFS structure from an on-disk directory.
|
||||
(define (vfs-from-directory osdir)
|
||||
(define iter-dir #f)
|
||||
(define output '())
|
||||
(set! iter-dir
|
||||
(lambda (dirpath)
|
||||
(define reldir (string-append osdir "/" dirpath))
|
||||
(define files '())
|
||||
(define contents (directory (string-append osdir dirpath)))
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(unless (string=? (string-copy name 0 1) ".")
|
||||
(if (directory-exists? (string-append reldir "/" name))
|
||||
(iter-dir (string-append dirpath "/" name))
|
||||
(set! files (cons (cons name (zfile #~,(call-with-input-file (string-append reldir "/" name) read-full-file))) files)))))
|
||||
contents)
|
||||
(set! output (cons (cons (string-append dirpath "/") (list->vector files)) output))))
|
||||
(define out (mapping (make-default-comparator)))
|
||||
(define (iter-dir dirpath)
|
||||
(define reldir (string-append osdir "/" dirpath))
|
||||
(define contents (directory reldir))
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(unless (string=? (string-copy name 0 1) ".")
|
||||
(if (directory-exists? (string-append reldir "/" name))
|
||||
(begin
|
||||
(iter-dir (if (string=? dirpath "") name (string-append dirpath "/" name)))
|
||||
(set! out (mapping-set! out (cons dirpath name) 'directory)))
|
||||
(set! out (mapping-set! out (cons dirpath name) (zfile #~,(call-with-input-file (string-append reldir "/" name) read-full-file)))))))
|
||||
contents))
|
||||
(iter-dir "")
|
||||
(list->vector output))
|
||||
|
||||
;; Calls `filter` for each file in the virtual filesystem, replacing its
|
||||
;; contents with an empty file if `filter` returns false.
|
||||
(define (filter-vfs vfs filter)
|
||||
(vector-map
|
||||
(lambda (dir)
|
||||
(cons (car dir)
|
||||
(vector-map
|
||||
(lambda (pair)
|
||||
(if (filter (car dir) (car pair))
|
||||
(cons (car pair) (cdr pair))
|
||||
(cons (car pair) "/dev/null")))
|
||||
(cdr dir))))
|
||||
vfs))
|
||||
(make-vfs out))
|
||||
|
||||
;; List extracted from go src/go/build/build.go.
|
||||
(define good-extensions '("go" "c" "cc" "cpp" "cxx" "m" "h" "hh" "hpp" "hxx" "f" "F" "for" "f90" "s" "S" "sx" "swig" "swigcxx" "syso"))
|
||||
|
|
@ -162,8 +201,13 @@
|
|||
|
||||
;; Returns a VFS, filtered down to only contain the contents of files that
|
||||
;; will be read during the processing of Go packages.
|
||||
(define (filter-vfs-for-package-reading vfs)
|
||||
(filter-vfs vfs
|
||||
(lambda (dir fname)
|
||||
(define (vfs-filter-for-go-package vfs)
|
||||
(vfs-dir-filter vfs
|
||||
(lambda (dir fname contents)
|
||||
(define extension (extract-extension fname (- (string-length fname) 1)))
|
||||
(member extension good-extensions))))))
|
||||
(member extension good-extensions))))
|
||||
|
||||
(define (vfs-to-json vfs)
|
||||
(mapping-map->list
|
||||
(lambda (k v) (list (car k) (cdr k) (if (eq? v 'directory) "" v)))
|
||||
(vfs-contents vfs)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue