123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187 |
- (define-module (guix modules)
- #:use-module (guix memoization)
- #:use-module (guix sets)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:use-module (ice-9 match)
- #:export (missing-dependency-error?
- missing-dependency-module
- missing-dependency-search-path
- file-name->module-name
- module-name->file-name
- source-module-dependencies
- source-module-closure
- live-module-closure
- guix-module-name?))
- (define-condition-type &missing-dependency-error &error
- missing-dependency-error?
- (module missing-dependency-module)
- (search-path missing-dependency-search-path))
- (define (colon-symbol? obj)
- "Return true if OBJ is a symbol that starts with a colon."
- (and (symbol? obj)
- (string-prefix? ":" (symbol->string obj))))
- (define (colon-symbol->keyword symbol)
- "Convert SYMBOL to a keyword after stripping its initial ':'."
- (symbol->keyword
- (string->symbol (string-drop (symbol->string symbol) 1))))
- (define (extract-dependencies clauses)
- "Return the list of modules imported according to the given 'define-module'
- CLAUSES."
- (let loop ((clauses clauses)
- (result '()))
- (match clauses
- (()
- (reverse result))
- ((#:use-module (module (or #:select #:hide #:prefix #:renamer) _)
- rest ...)
- (loop rest (cons module result)))
- ((#:use-module module rest ...)
- (loop rest (cons module result)))
- ((#:autoload module _ rest ...)
- (loop rest (cons module result)))
- (((or #:export #:re-export #:export-syntax #:re-export-syntax
- #:re-export-and-replace #:replace #:version)
- _ rest ...)
- (loop rest result))
- (((or #:pure #:no-backtrace) rest ...)
- (loop rest result))
- (((? colon-symbol? symbol) rest ...)
- (loop (cons (colon-symbol->keyword symbol) rest)
- result)))))
- (define module-file-dependencies
- (mlambda (file)
- "Return the list of the names of modules that the Guile module in FILE
- depends on."
- (call-with-input-file file
- (lambda (port)
- (match (read port)
- (('define-module name clauses ...)
- (extract-dependencies clauses))
-
- (_
- '()))))))
- (define file-name->module-name
- (let ((not-slash (char-set-complement (char-set #\/))))
- (lambda (file)
- "Return the module name (a list of symbols) corresponding to FILE."
- (map string->symbol
- (string-tokenize (string-drop-right file 4) not-slash)))))
- (define (module-name->file-name module)
- "Return the file name for MODULE."
- (string-append (string-join (map symbol->string module) "/")
- ".scm"))
- (define (guix-module-name? name)
- "Return true if NAME (a list of symbols) denotes a Guix module."
- (match name
- (('guix _ ...) #t)
- (('gnu _ ...) #t)
- (_ #f)))
- (define %source-less-modules
-
-
- '((system syntax) ;2.0, defined in boot-9
- (ice-9 ports internal) ;2.2, defined in (ice-9 ports)
- (system syntax internal)))
- (define* (source-module-dependencies module #:optional (load-path %load-path))
- "Return the modules used by MODULE by looking at its source code."
- (if (member module %source-less-modules)
- '()
- (match (search-path load-path (module-name->file-name module))
- ((? string? file)
- (module-file-dependencies file))
- (#f
- (raise (condition (&missing-dependency-error
- (module module)
- (search-path load-path))))))))
- (define* (module-closure modules
- #:key
- (select? guix-module-name?)
- (dependencies source-module-dependencies))
- "Return the closure of MODULES, calling DEPENDENCIES to determine the list
- of modules used by a given module. MODULES and the result are a list of Guile
- module names. Only modules that match SELECT? are considered."
- (let loop ((modules modules)
- (result '())
- (visited (set)))
- (match modules
- (()
- (reverse result))
- ((module rest ...)
- (cond ((set-contains? visited module)
- (loop rest result visited))
- ((select? module)
- (loop (append (dependencies module) rest)
- (cons module result)
- (set-insert module visited)))
- (else
- (loop rest result visited)))))))
- (define* (source-module-closure modules
- #:optional (load-path %load-path)
- #:key (select? guix-module-name?))
- "Return the closure of MODULES by reading 'define-module' forms in their
- source code. MODULES and the result are a list of Guile module names. Only
- modules that match SELECT? are considered."
- (module-closure modules
- #:dependencies (cut source-module-dependencies <> load-path)
- #:select? select?))
- (define* (live-module-closure modules
- #:key (select? guix-module-name?))
- "Return the closure of MODULES, determined by looking at live (loaded)
- module information. MODULES and the result are a list of Guile module names.
- Only modules that match SELECT? are considered."
- (define (dependencies module)
- (map module-name
- (delq the-scm-module (module-uses (resolve-module module)))))
- (module-closure modules
- #:dependencies dependencies
- #:select? select?))
|