fix `raco setup' for splicing collections
Closes PR 12676
This commit is contained in:
Matthew Flatt
parent
1b0f6cc995
commit
5ffb9389ac
|
|
@ -3,9 +3,7 @@
|
|||
setup/variant)
|
||||
(provide find-exe)
|
||||
|
||||
;; Find executable relative to the "mzlib"
|
||||
;; collection.
|
||||
(define (find-exe mred? [variant (system-type 'gc)])
|
||||
(define (find-exe [mred? #f] [variant (system-type 'gc)])
|
||||
(let* ([base (if mred?
|
||||
(find-gui-bin-dir)
|
||||
(find-console-bin-dir))]
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@
|
|||
compiler/embed-sig
|
||||
compiler/embed-unit
|
||||
racket/runtime-path
|
||||
launcher/launcher))
|
||||
launcher/launcher
|
||||
compiler/find-exe))
|
||||
|
||||
@title{API for Creating Executables}
|
||||
|
||||
|
|
@ -450,14 +451,13 @@ Includes the identifiers provided by @racketmodname[compiler/embed].}
|
|||
|
||||
A unit that imports nothing and exports @racket[compiler:embed^].}
|
||||
|
||||
@section{Finding the name of the executable}
|
||||
@section{Finding the Racket Executable}
|
||||
|
||||
@defmodule[compiler/find-exe]
|
||||
|
||||
@defproc[(find-exe [gracket? boolean?]
|
||||
@defproc[(find-exe [gracket? any/c #f]
|
||||
[variant (or/c 'cgc '3m) (system-type 'gc)])
|
||||
path?]{
|
||||
|
||||
Finds the path to the racket (or gracket) executable.
|
||||
}
|
||||
|
||||
Finds the path to the @exec{racket} or @exec{gracket} (when
|
||||
@racket[gracket?] is true) executable.}
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
@(require scribble/manual
|
||||
scribble/bnf
|
||||
"common.rkt"
|
||||
(for-label racket/base))
|
||||
(for-label racket/base
|
||||
racket/contract))
|
||||
|
||||
@title[#:tag "link"]{@exec{raco link}: Library Collection Links}
|
||||
|
||||
|
|
@ -111,7 +112,7 @@ Full command-line options:
|
|||
@defmodule[setup/link]
|
||||
|
||||
@defproc[(links [dir path?] ...
|
||||
[#:user? user? #t]
|
||||
[#:user? user? any/c #t]
|
||||
[#:file file (or/c path-string? #f) #f]
|
||||
[#:name name (or/c string? #f) #f]
|
||||
[#:root? root? any/c #f]
|
||||
|
|
@ -119,7 +120,8 @@ Full command-line options:
|
|||
[#:error error-proc (symbol? string? any/c ... . -> . any) error]
|
||||
[#:remove? remove? any/c #f]
|
||||
[#:show? show? any/c #f]
|
||||
[#:repair? repair? any/c #f])
|
||||
[#:repair? repair? any/c #f]
|
||||
[#:with-path? with-path? any/c #f])
|
||||
list?]{
|
||||
|
||||
A function version of the @exec{raco link} command that always works
|
||||
|
|
@ -132,9 +134,11 @@ The @racket[error-proc] argument is called to raise exceptions that
|
|||
would be fatal to the @exec{raco link} command.
|
||||
|
||||
If @racket[remove?] is true, the result is a list of entries that were
|
||||
removed from the file. If @racket[remove?] is false but
|
||||
removed from the file. If @racket[remove?] is @racket[#f] but
|
||||
@racket[root?] is true, the result is a list of paths for collection
|
||||
roots. If @racket[remove?] and @racket[root?] are both false, the
|
||||
result is a list of top-level collection names (as strings) that are
|
||||
mapped by @racket[file] and that apply to the running version of
|
||||
Racket.}
|
||||
roots. If @racket[remove?] and @racket[root?] are both @racket[#f],
|
||||
the result is a list for top-level collections that are mapped by
|
||||
@racket[file] and that apply to the running version of Racket; the
|
||||
list is a list of strings for collection names if @racket[with-path?]
|
||||
is @racket[#f], or it is a list of pairs of collection-name strings
|
||||
and complete paths if @racket[with-path?] is true.}
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
#:remove? [remove? #f]
|
||||
#:show? [show? #f]
|
||||
#:repair? [repair? #f]
|
||||
#:with-path? [with-path? #f]
|
||||
. dirs)
|
||||
(define (check-name name)
|
||||
(unless (and (regexp-match #rx"^[a-zA-z0-9+_%-]+$" name)
|
||||
|
|
@ -203,6 +204,9 @@
|
|||
(when (and (string? (car e))
|
||||
(or (null? (cddr e))
|
||||
(regexp-match? (caddr e) (version))))
|
||||
(hash-set! ht (car e) #t)))
|
||||
(hash-map ht (lambda (k e) k))))))
|
||||
(hash-set! ht (car e) (cadr e))))
|
||||
(hash-map ht (lambda (k p)
|
||||
(if with-path?
|
||||
(cons k (simplify p))
|
||||
k)))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -203,41 +203,57 @@
|
|||
(setup-printf "WARNING" "~a" (exn->string exn))
|
||||
v)
|
||||
|
||||
;; collection->cc : listof path -> cc/#f
|
||||
(define collection->cc-table (make-hash))
|
||||
(define (collection->cc collection-p
|
||||
;; Maps a colletion name to a list of `cc's:
|
||||
(define collection-ccs-table (make-hash))
|
||||
|
||||
;; collection-cc! : listof-path .... -> cc
|
||||
(define (collection-cc! collection-p
|
||||
#:path [dir (apply collection-path collection-p)]
|
||||
#:omit-root [omit-root #f]
|
||||
#:info-root [given-info-root #f]
|
||||
#:info-path [info-path #f]
|
||||
#:info-path-mode [info-path-mode 'relative])
|
||||
(hash-ref! collection->cc-table collection-p
|
||||
(lambda ()
|
||||
(define info-root
|
||||
(or given-info-root
|
||||
(ormap (lambda (p)
|
||||
(parameterize ([current-library-collection-paths (list p)]
|
||||
;; to disable collection links file:
|
||||
[use-user-specific-search-paths #f])
|
||||
(and (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(apply collection-path collection-p))
|
||||
p)))
|
||||
(current-library-collection-paths))))
|
||||
(let ([dir (apply collection-path collection-p)])
|
||||
(unless (directory-exists? dir)
|
||||
(error name-sym "directory does not exist for collection: ~s"
|
||||
(string-join (map path->string collection-p) "/")))
|
||||
(make-cc* collection-p
|
||||
(define info-root
|
||||
(or given-info-root
|
||||
(ormap (lambda (p)
|
||||
(parameterize ([current-library-collection-paths (list p)]
|
||||
;; to disable collection links file:
|
||||
[use-user-specific-search-paths #f])
|
||||
(and (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(apply collection-path collection-p))
|
||||
p)))
|
||||
(current-library-collection-paths))))
|
||||
(unless (directory-exists? dir)
|
||||
(error name-sym "directory: ~e does not exist for collection: ~s"
|
||||
dir
|
||||
(string-join (map path->string collection-p) "/")))
|
||||
(unless info-root
|
||||
(error name-sym "cannot find info root for collection: ~s and path: ~e"
|
||||
(string-join (map path->string collection-p) "/")
|
||||
dir))
|
||||
(define new-cc
|
||||
(make-cc* collection-p
|
||||
dir
|
||||
(if (eq? omit-root 'dir)
|
||||
dir
|
||||
(if (eq? omit-root 'dir)
|
||||
dir
|
||||
omit-root) ; #f => `omitted-paths' can reconstruct it
|
||||
info-root
|
||||
(or info-path
|
||||
(build-path info-root "info-domain" "compiled" "cache.rktd"))
|
||||
info-path-mode
|
||||
;; by convention, all collections have "version" 1 0. This
|
||||
;; forces them to conflict with each other.
|
||||
(list (cons 'lib (map path->string collection-p)) 1 0))))))
|
||||
omit-root) ; #f => `omitted-paths' can reconstruct it
|
||||
info-root
|
||||
(or info-path
|
||||
(build-path info-root "info-domain" "compiled" "cache.rktd"))
|
||||
info-path-mode
|
||||
;; by convention, all collections have "version" 1 0. This
|
||||
;; forces them to conflict with each other.
|
||||
(list (cons 'lib (map path->string collection-p)) 1 0)))
|
||||
(when new-cc
|
||||
(hash-update! collection-ccs-table
|
||||
collection-p
|
||||
(lambda (lst) (cons new-cc lst))
|
||||
null))
|
||||
new-cc)
|
||||
|
||||
;; collection->ccs : listof-path -> listof-cc
|
||||
(define (collection->ccs collection-p)
|
||||
(hash-ref collection-ccs-table collection-p null))
|
||||
|
||||
;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f
|
||||
;; converts a planet package spec into the information needed to create a cc structure
|
||||
|
|
@ -257,9 +273,9 @@
|
|||
owner pkg-name maj min))))]
|
||||
[_ spec]))
|
||||
|
||||
(define (planet->cc path #:omit-root [omit-root path] owner pkg-file extra-path maj min)
|
||||
(define (planet-cc! path #:omit-root [omit-root path] owner pkg-file extra-path maj min)
|
||||
(unless (path? path)
|
||||
(error 'planet->cc "non-path when building package ~e" pkg-file))
|
||||
(error 'planet-cc! "non-path when building package ~e" pkg-file))
|
||||
(and (directory-exists? path)
|
||||
(make-cc* #f
|
||||
path
|
||||
|
|
@ -275,7 +291,7 @@
|
|||
(define (planet-cc->sub-cc cc subdir)
|
||||
(match-let ([(list (list 'planet owner pkg-file extra-path ...) maj min)
|
||||
(cc-shadowing-policy cc)])
|
||||
(planet->cc (apply build-path (cc-path cc) (map bytes->path subdir))
|
||||
(planet-cc! (apply build-path (cc-path cc) (map bytes->path subdir))
|
||||
#:omit-root (cc-omit-root cc)
|
||||
owner
|
||||
pkg-file
|
||||
|
|
@ -283,47 +299,52 @@
|
|||
maj
|
||||
min)))
|
||||
|
||||
(define all-collections
|
||||
(let ([ht (make-hash)])
|
||||
(define (maybe collection ->cc)
|
||||
(hash-ref ht collection
|
||||
(lambda ()
|
||||
(let ([cc (->cc collection)])
|
||||
(when cc (hash-set! ht collection cc))))))
|
||||
(for ([cp (current-library-collection-paths)]
|
||||
;; Add in all non-planet collections:
|
||||
(for ([cp (current-library-collection-paths)]
|
||||
#:when (directory-exists? cp)
|
||||
[collection (directory-list cp)]
|
||||
#:when (directory-exists? (build-path cp collection)))
|
||||
(collection-cc! (list collection)
|
||||
#:path (build-path cp collection)))
|
||||
(let ([main-collects (find-collects-dir)])
|
||||
(define (cc! col #:path path)
|
||||
(collection-cc! col
|
||||
#:path path
|
||||
#:info-root main-collects
|
||||
#:info-path-mode 'abs-in-relative
|
||||
#:omit-root 'dir))
|
||||
(for ([c+p (in-list (links #:user? #f #:with-path? #t))])
|
||||
(cc! (list (string->path (car c+p)))
|
||||
#:path (cdr c+p)))
|
||||
(for ([cp (in-list (links #:root? #t #:user? #f))]
|
||||
#:when (directory-exists? cp)
|
||||
[collection (directory-list cp)]
|
||||
#:when (directory-exists? (build-path cp collection)))
|
||||
(cc! (list collection)
|
||||
#:path (build-path cp collection))))
|
||||
(when (make-user)
|
||||
(let ([user-collects (find-user-collects-dir)])
|
||||
(define (cc! col #:path path)
|
||||
(unless user-collects
|
||||
(error name-sym "cannot setup linked collection without a user-collection root"))
|
||||
(collection-cc! col
|
||||
#:path path
|
||||
#:info-root user-collects
|
||||
#:info-path-mode 'abs-in-relative
|
||||
#:omit-root 'dir))
|
||||
(for ([c+p (in-list (links #:with-path? #t))])
|
||||
(cc! (list (string->path (car c+p)))
|
||||
#:path (cdr c+p)))
|
||||
(for ([cp (in-list (links #:root? #t))]
|
||||
#:when (directory-exists? cp)
|
||||
[collection (directory-list cp)]
|
||||
#:when (directory-exists? (build-path cp collection)))
|
||||
(maybe (list collection) collection->cc))
|
||||
(let ([main-collects (find-collects-dir)])
|
||||
(define (->cc col)
|
||||
(collection->cc col
|
||||
#:info-root main-collects
|
||||
#:info-path-mode 'abs-in-relative
|
||||
#:omit-root 'dir))
|
||||
(for ([c (in-list (links #:user? #f))])
|
||||
(maybe (list (string->path c)) ->cc))
|
||||
(for ([cp (in-list (links #:root? #t #:user? #f))]
|
||||
#:when (directory-exists? cp)
|
||||
[collection (directory-list cp)]
|
||||
#:when (directory-exists? (build-path cp collection)))
|
||||
(maybe (list collection) ->cc)))
|
||||
(when (make-user)
|
||||
(let ([user-collects (find-user-collects-dir)])
|
||||
(define (->cc col)
|
||||
(collection->cc col
|
||||
#:info-root user-collects
|
||||
#:info-path-mode 'abs-in-relative
|
||||
#:omit-root 'dir))
|
||||
(for ([c (in-list (links))])
|
||||
(maybe (list (string->path c)) ->cc))
|
||||
(for ([cp (in-list (links #:root? #t))]
|
||||
#:when (directory-exists? cp)
|
||||
[collection (directory-list cp)]
|
||||
#:when (directory-exists? (build-path cp collection)))
|
||||
(maybe (list collection) ->cc))))
|
||||
(hash-map ht (lambda (k v) v))))
|
||||
(cc! (list collection)
|
||||
#:path (build-path cp collection)))))
|
||||
|
||||
;; `all-collections' lists all top-level collections (not from Planet):
|
||||
(define all-collections (apply append (hash-map collection-ccs-table (lambda (k v) v))))
|
||||
|
||||
;; Close over sub-collections
|
||||
(define (collection-closure collections-to-compile make-subs)
|
||||
(define (get-subs cc)
|
||||
|
|
@ -363,7 +384,7 @@
|
|||
|
||||
(define (build-collection-tree cc)
|
||||
(define (make-child-cc parent-cc name)
|
||||
(collection->cc (append (cc-collection parent-cc) (list name))
|
||||
(collection-cc! (append (cc-collection parent-cc) (list name))
|
||||
#:info-root (cc-info-root cc)
|
||||
#:info-path (cc-info-path cc)
|
||||
#:info-path-mode (cc-info-path-mode cc)
|
||||
|
|
@ -394,27 +415,37 @@
|
|||
null))])
|
||||
(list cc srcs children-ccs)))))
|
||||
(map build-collection-tree collections-to-compile))
|
||||
|
||||
|
||||
|
||||
|
||||
(define (plt-collection-closure collections-to-compile)
|
||||
(define (make-children-ccs cc children)
|
||||
(map (lambda (child)
|
||||
(collection->cc (append (cc-collection cc) (list child))
|
||||
#:info-root (cc-info-root cc)
|
||||
#:info-path (cc-info-path cc)
|
||||
#:info-path-mode (cc-info-path-mode cc)
|
||||
#:omit-root (cc-omit-root cc)))
|
||||
(collection-cc! (append (cc-collection cc) (list child))
|
||||
#:path (build-path (cc-path cc) child)
|
||||
#:info-root (cc-info-root cc)
|
||||
#:info-path (cc-info-path cc)
|
||||
#:info-path-mode (cc-info-path-mode cc)
|
||||
#:omit-root (cc-omit-root cc)))
|
||||
children))
|
||||
(collection-closure collections-to-compile make-children-ccs))
|
||||
|
||||
(define (check-again-all given-ccs)
|
||||
(define (lookup-collection-closure collections-to-compile)
|
||||
(define (lookup-children-ccs cc children)
|
||||
(apply
|
||||
append
|
||||
(map (lambda (child)
|
||||
(collection->ccs (append (cc-collection cc) (list child))))
|
||||
children)))
|
||||
(collection-closure collections-to-compile lookup-children-ccs))
|
||||
|
||||
(define all-collections-closure (plt-collection-closure all-collections))
|
||||
|
||||
(define (check-against-all given-ccs)
|
||||
(define (cc->name cc)
|
||||
(string-join (map path->string (cc-collection cc)) "/"))
|
||||
(define (cc->cc+name+id cc)
|
||||
(list cc (cc->name cc) (file-or-directory-identity (cc-path cc))))
|
||||
(define all-ccs+names+ids
|
||||
(map cc->cc+name+id (plt-collection-closure all-collections)))
|
||||
(map cc->cc+name+id all-collections-closure))
|
||||
;; given collections
|
||||
(define given-ccs+names+ids (map cc->cc+name+id given-ccs))
|
||||
;; descendants of given collections
|
||||
|
|
@ -422,7 +453,7 @@
|
|||
(remove-duplicates
|
||||
(append-map
|
||||
(lambda (cc)
|
||||
(map cc->name (remq cc (plt-collection-closure (list cc)))))
|
||||
(map cc->name (remq cc (lookup-collection-closure (list cc)))))
|
||||
given-ccs)))
|
||||
;; given collections without duplicates and without ones that are already
|
||||
;; descendants
|
||||
|
|
@ -431,7 +462,8 @@
|
|||
(filter (lambda (cc+name+id)
|
||||
(not (member (cadr cc+name+id) descendants-names)))
|
||||
given-ccs+names+ids)
|
||||
(lambda (x y) (equal? (cadr x) (cadr y)))))
|
||||
(lambda (x y) (and (equal? (cadr x) (cadr y))
|
||||
(equal? (cc-path (car x)) (cc-path (car y)))))))
|
||||
;; check that there are no bad duplicates in the given list
|
||||
(for ([given-cc+name+id (in-list given*-ccs+names+ids)])
|
||||
(cond
|
||||
|
|
@ -455,18 +487,32 @@
|
|||
(define top-level-plt-collects
|
||||
(if no-specific-collections?
|
||||
all-collections
|
||||
(check-again-all
|
||||
(filter-map
|
||||
(lambda (c)
|
||||
(collection->cc (append-map (lambda (s)
|
||||
(map string->path
|
||||
(regexp-split #rx"/" s)))
|
||||
c)))
|
||||
x-specific-collections))))
|
||||
(check-against-all
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (c)
|
||||
(define elems (append-map (lambda (s)
|
||||
(map string->path
|
||||
(regexp-split #rx"/" s)))
|
||||
c))
|
||||
(define ccs
|
||||
(collection->ccs elems))
|
||||
(when (null? ccs)
|
||||
;; let `collection-path' complain about the name, if that's the problem:
|
||||
(apply collection-path elems)
|
||||
;; otherwise, it must be an issue with different ways to
|
||||
;; spell the name
|
||||
(error name-sym
|
||||
(error name-sym
|
||||
"given collection path: \"~a\" is not in canonical form (e.g., wrong case on a case-insensitive filesystem)"
|
||||
(string-join c "/"))))
|
||||
ccs)
|
||||
x-specific-collections)))))
|
||||
|
||||
(define planet-collects
|
||||
(if (make-planet)
|
||||
(filter-map (lambda (spec) (apply planet->cc spec))
|
||||
(filter-map (lambda (spec) (apply planet-cc! spec))
|
||||
(if no-specific-collections?
|
||||
(get-all-planet-packages)
|
||||
(filter-map planet-spec->planet-list
|
||||
|
|
@ -482,7 +528,7 @@
|
|||
|
||||
(define ccs-to-compile
|
||||
(append
|
||||
(sort-collections (plt-collection-closure top-level-plt-collects))
|
||||
(sort-collections (lookup-collection-closure top-level-plt-collects))
|
||||
planet-dirs-to-compile))
|
||||
|
||||
|
||||
|
|
@ -761,7 +807,8 @@
|
|||
(setup-printf #f "--- compiling collections ---")
|
||||
(match (parallel-workers)
|
||||
[(? (lambda (x) (x . > . 1)))
|
||||
(compile-cc (collection->cc (list (string->path "racket"))) 0)
|
||||
(for/fold ([gcs 0]) ([cc (in-list (collection->ccs (list (string->path "racket"))))])
|
||||
(compile-cc cc 0))
|
||||
(managed-compile-zo (collection-file-path "parallel-build-worker.rkt" "setup"))
|
||||
(with-specified-mode
|
||||
(lambda ()
|
||||
|
|
|
|||
243
collects/tests/racket/link.rkt
Normal file
243
collects/tests/racket/link.rkt
Normal file
|
|
@ -0,0 +1,243 @@
|
|||
#lang racket
|
||||
(require setup/link
|
||||
compiler/find-exe)
|
||||
|
||||
(define-syntax-rule (test expect expr)
|
||||
(do-test expect expr 'expr))
|
||||
|
||||
(define (do-test expect val expr)
|
||||
(unless (equal? expect val)
|
||||
(eprintf "test failed: ~.s; expected: ~e; actual: ~e\n"
|
||||
expr expect val)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; set up
|
||||
|
||||
(define work-dir (build-path (find-system-path 'temp-dir) "link-test"))
|
||||
(when (directory-exists? work-dir)
|
||||
(delete-directory/files work-dir))
|
||||
(make-directory work-dir)
|
||||
|
||||
(define link-file (build-path work-dir "links"))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; running Racket
|
||||
|
||||
(define racket-exe (find-exe #f))
|
||||
|
||||
(define (run-racket args)
|
||||
(let ([o (open-output-string)]
|
||||
[eo (open-output-string)])
|
||||
(with-handlers ([exn? (lambda (exn) (raise exn))])
|
||||
(parameterize ([current-output-port o]
|
||||
[current-error-port eo])
|
||||
(apply system*
|
||||
racket-exe
|
||||
(list* "-C"
|
||||
link-file
|
||||
args))))
|
||||
(values (get-output-string o)
|
||||
(get-output-string eo))))
|
||||
|
||||
(define (test-racket result-str args)
|
||||
(define-values (out err) (run-racket args))
|
||||
(unless (string=? "" err)
|
||||
(eprintf "test stderr: ~e\n" err))
|
||||
(let ([eo (open-output-string)])
|
||||
(display result-str eo)
|
||||
(newline eo)
|
||||
(do-test (get-output-string eo)
|
||||
out
|
||||
`(racket ,result-str ',args))))
|
||||
|
||||
(define (run-setup collection
|
||||
#:err [err-rx #f]
|
||||
#:no-docs? [no-docs? #f])
|
||||
(printf "setup ~s\n" collection)
|
||||
(define-values (out err)
|
||||
(run-racket (append `("-l-" "setup")
|
||||
(if no-docs?
|
||||
`("-D")
|
||||
null)
|
||||
`("-l" ,collection))))
|
||||
(cond
|
||||
[err-rx
|
||||
(unless (regexp-match err-rx err)
|
||||
(eprintf "setup non-matching stderr: ~e\n" err))]
|
||||
[else
|
||||
(unless (string=? "" err)
|
||||
(eprintf "setup stderr: ~e\n" err))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; check setup errs
|
||||
|
||||
(run-setup "Racket"
|
||||
#:err "collection not found|not in canonical form")
|
||||
|
||||
;; ----------------------------------------
|
||||
;; simple collection link
|
||||
|
||||
(test null (links #:file link-file))
|
||||
(test null (links #:file link-file #:root? #t))
|
||||
|
||||
(define c1-dir (build-path work-dir "c1"))
|
||||
(make-directory c1-dir)
|
||||
(test '("c1") (links c1-dir #:file link-file))
|
||||
|
||||
(test '("c1") (links #:file link-file))
|
||||
(test (list (cons "c1" c1-dir)) (links #:with-path? #t #:file link-file))
|
||||
(test null (links #:file link-file #:root? #t))
|
||||
|
||||
(with-output-to-file (build-path c1-dir "m1.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'm1\n")))
|
||||
|
||||
(test-racket "'m1" '("-l" "c1/m1"))
|
||||
|
||||
(run-setup "c1")
|
||||
(test #t (file-exists? (build-path c1-dir "compiled" "m1_rkt.zo")))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; splicing with "mzlib"
|
||||
|
||||
(define mzlib-dir (build-path work-dir "mzlib"))
|
||||
(make-directory mzlib-dir)
|
||||
(test '("c1" "mzlib") (links mzlib-dir #:file link-file))
|
||||
|
||||
(test '("c1" "mzlib") (links #:file link-file))
|
||||
(test null (links #:file link-file #:root? #t))
|
||||
|
||||
(with-output-to-file (build-path mzlib-dir "m1.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'mz1\n")))
|
||||
|
||||
(test-racket "'mz1" '("-l" "mzlib/m1"))
|
||||
|
||||
(test-racket "#<channel>" '("-l" "racket/base" "-l" "mzlib/cml" "-e" "(channel)"))
|
||||
|
||||
(run-setup "mzlib" #:no-docs? #t)
|
||||
(test #t (file-exists? (build-path mzlib-dir "compiled" "m1_rkt.zo")))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; splicing via new root directory
|
||||
|
||||
(define new-root-dir (build-path work-dir "collects"))
|
||||
(make-directory new-root-dir)
|
||||
|
||||
(define another-c1-dir (build-path new-root-dir "c1"))
|
||||
(make-directory another-c1-dir)
|
||||
|
||||
(with-output-to-file (build-path another-c1-dir "m2.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'm2\n")))
|
||||
(with-output-to-file (build-path c1-dir "m3.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'm3\n")))
|
||||
|
||||
(test null (links #:file link-file #:root? #t))
|
||||
(test (list new-root-dir) (links new-root-dir #:file link-file #:root? #t))
|
||||
|
||||
(test-racket "'m1" '("-l" "c1/m1"))
|
||||
(test-racket "'m2" '("-l" "c1/m2"))
|
||||
(test-racket "'m3" '("-l" "c1/m3"))
|
||||
|
||||
(run-setup "c1")
|
||||
(test #t (file-exists? (build-path c1-dir "compiled" "m1_rkt.zo")))
|
||||
(test #t (file-exists? (build-path another-c1-dir "compiled" "m2_rkt.zo")))
|
||||
(test #t (file-exists? (build-path c1-dir "compiled" "m3_rkt.zo")))
|
||||
|
||||
;; original "c1" should take precdence over the new addition,
|
||||
;; just based on the order of addition
|
||||
|
||||
(with-output-to-file (build-path another-c1-dir "m3.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'bad-m3\n")))
|
||||
(test-racket "'m3" '("-l" "c1/m3"))
|
||||
|
||||
(run-setup "c1")
|
||||
;; questionable: maybe modules unreachable via `require' shouldn't be compiled:
|
||||
(test #t (file-exists? (build-path another-c1-dir "compiled" "m3_rkt.zo")))
|
||||
|
||||
(with-output-to-file (build-path another-c1-dir "m4.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n(require c1/m1)\n")))
|
||||
(test-racket "'m1" '("-l" "c1/m4"))
|
||||
|
||||
(with-output-to-file (build-path another-c1-dir "m5.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n(require c1/m3)\n")))
|
||||
(test-racket "'m3" '("-l" "c1/m5"))
|
||||
|
||||
;; Relative path accesses a relative file --- which is inconsistent
|
||||
;; with module-path collapses, so this shouldn't be done, but
|
||||
;; check it anyway:
|
||||
(with-output-to-file (build-path another-c1-dir "m6.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n(require \"m3.rkt\")\n")))
|
||||
(test-racket "'bad-m3" '("-l" "c1/m6"))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; omits in linked collections:
|
||||
|
||||
(with-output-to-file (build-path c1-dir "info.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang setup/infotab\n(define compile-omit-paths '(\"b1.rkt\"))\n")))
|
||||
(with-output-to-file (build-path c1-dir "b1.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'b1\n")))
|
||||
|
||||
(with-output-to-file (build-path another-c1-dir "info.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang setup/infotab\n(define compile-omit-paths '(\"b2.rkt\"))\n")))
|
||||
(with-output-to-file (build-path another-c1-dir "b2.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'b2\n")))
|
||||
|
||||
(run-setup "c1")
|
||||
|
||||
(test #f (file-exists? (build-path c1-dir "compiled" "b1_rkt.zo")))
|
||||
(test #f (file-exists? (build-path another-c1-dir "compiled" "b2_rkt.zo")))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; subcollections:
|
||||
|
||||
(define c1/s1-dir (build-path c1-dir "s1"))
|
||||
(make-directory c1/s1-dir)
|
||||
|
||||
(define c1/s2-dir (build-path another-c1-dir "s2"))
|
||||
(make-directory c1/s2-dir)
|
||||
|
||||
(with-output-to-file (build-path c1/s1-dir "n1.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'n1\n")))
|
||||
|
||||
(with-output-to-file (build-path c1/s2-dir "n2.rkt")
|
||||
(lambda ()
|
||||
(printf "#lang racket/base\n'n2\n")))
|
||||
|
||||
(test-racket "'n1" '("-l" "c1/s1/n1"))
|
||||
(test-racket "'n2" '("-l" "c1/s2/n2"))
|
||||
|
||||
(run-setup "c1/s1")
|
||||
(test #t (file-exists? (build-path c1/s1-dir "compiled" "n1_rkt.zo")))
|
||||
(run-setup "c1/s2")
|
||||
(test #t (file-exists? (build-path c1/s2-dir "compiled" "n2_rkt.zo")))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; docs in a linked collection:
|
||||
|
||||
(with-output-to-file (build-path c1-dir "c1.scrbl")
|
||||
(lambda ()
|
||||
(printf "#lang scribble/manual\n@title{C1}@defmodule[c1]\n")))
|
||||
(with-output-to-file (build-path c1-dir "info.rkt")
|
||||
#:exists 'truncate
|
||||
(lambda ()
|
||||
(printf "#lang setup/infotab\n(define scribblings '((\"c1.scrbl\")))\n")))
|
||||
|
||||
(run-setup "c1")
|
||||
(test #t (file-exists? (build-path c1-dir "doc" "c1" "index.html")))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; clean up
|
||||
|
||||
;(delete-directory/files work-dir)
|
||||
Loading…
Reference in New Issue
Block a user