269 lines
11 KiB
Racket
269 lines
11 KiB
Racket
|
#lang racket/base
|
||
|
|
|
||
|
|
(require racket/contract
|
||
|
|
racket/format
|
||
|
|
racket/match
|
||
|
|
racket/set
|
||
|
|
"util.rkt")
|
||
|
|
|
||
|
|
(provide imports)
|
||
|
|
|
||
|
|
;;; Finding completion candidates from imports
|
||
|
|
|
||
|
|
;; drracket/check-syntax tells us about local definitions (which is
|
||
|
|
;; great!), and, tells us about imported definitions -- but only those
|
||
|
|
;; already _used_. Obviously, a major use case for completion is
|
||
|
|
;; typing _new_ uses of available definitions, too. e.g. "What is that
|
||
|
|
;; string-xxx function I'm not yet using in this file?" So we want to
|
||
|
|
;; supply that full set.
|
||
|
|
;;
|
||
|
|
;; If you have a namespace from module->namespace, you can use
|
||
|
|
;; namespace-mapped-symbols -- easy! However we do NOT want to
|
||
|
|
;; instantiate the module, i.e. "run the user's code". We want to
|
||
|
|
;; supply this information using the same sort of "passive" analaysis
|
||
|
|
;; done by check-syntax, before the user even runs the file (if ever).
|
||
|
|
;;
|
||
|
|
;; module->exports is a good starting point, but not the whole answer:
|
||
|
|
;; Imports can be filtered and renamed -- e.g. only-in, except-in,
|
||
|
|
;; prefix-in, rename-in.
|
||
|
|
;;
|
||
|
|
;; AFAICT there is no good way to get completions from all imported
|
||
|
|
;; identifiers, except attempting to parse the complete #%require
|
||
|
|
;; grammar including `prefix` and renaming forms like `just-meta`, and
|
||
|
|
;; apply that information to tweak the answer from module->exports.
|
||
|
|
|
||
|
|
;; It is important to run this with the correct parameterization of
|
||
|
|
;; current-namespace and current-load-relative-directory.
|
||
|
|
(define/contract (imports stx [sos (mutable-set)])
|
||
|
|
(->* (syntax?) (set-mutable?) set-mutable?)
|
||
|
|
|
||
|
|
(define (handle-module stx)
|
||
|
|
(syntax-case stx (module #%module-begin #%plain-module-begin #%require)
|
||
|
|
[(module _id lang (#%module-begin e ...))
|
||
|
|
(handle-module-level #'(e ...) #'lang)]
|
||
|
|
[(module _id lang (#%plain-module-begin e ...))
|
||
|
|
(handle-module-level #'(e ...) #'lang)]))
|
||
|
|
|
||
|
|
(define (handle-module-level es lang)
|
||
|
|
(module-exported-strings lang lang)
|
||
|
|
(for ([e (in-syntax es)])
|
||
|
|
(syntax-case* e (#%require module module*) symbolic-compare?
|
||
|
|
[(#%require e ...)
|
||
|
|
(for ([spec (in-syntax #'(e ...))])
|
||
|
|
(handle-raw-require-spec spec lang))]
|
||
|
|
[(module _id sub-mod-lang (_mb e ...))
|
||
|
|
(handle-module-level #'(e ...) #'sub-mod-lang)]
|
||
|
|
[(module* _id sub-mod-lang (_mb e ...))
|
||
|
|
(handle-module-level #'(e ...) (if (syntax-e #'sub-mod-lang)
|
||
|
|
#'sub-mod-lang
|
||
|
|
lang))]
|
||
|
|
[ _ (void)])))
|
||
|
|
|
||
|
|
(define (handle-raw-require-spec spec lang)
|
||
|
|
(syntax-case* spec (for-meta for-syntax for-template for-label just-meta) symbolic-compare?
|
||
|
|
[(for-meta _phase specs ...)
|
||
|
|
(for ([spec (in-syntax #'(specs ...))])
|
||
|
|
(handle-phaseless-spec spec lang))]
|
||
|
|
[(for-syntax specs ...)
|
||
|
|
(for ([spec (in-syntax #'(specs ...))])
|
||
|
|
(handle-phaseless-spec spec lang))]
|
||
|
|
[(for-template specs ...)
|
||
|
|
(for ([spec (in-syntax #'(specs ...))])
|
||
|
|
(handle-phaseless-spec spec lang))]
|
||
|
|
[(for-label specs ...)
|
||
|
|
(for ([spec (in-syntax #'(specs ...))])
|
||
|
|
(handle-phaseless-spec spec lang))]
|
||
|
|
[(just-meta phase specs ...)
|
||
|
|
(for ([spec (in-syntax #'(specs ...))])
|
||
|
|
(handle-raw-require-spec spec lang))]
|
||
|
|
[raw-module-path
|
||
|
|
(handle-phaseless-spec #'raw-module-path lang)]))
|
||
|
|
|
||
|
|
(define (handle-phaseless-spec spec lang)
|
||
|
|
(syntax-case* spec (only prefix all-except prefix-all-except rename)
|
||
|
|
symbolic-compare?
|
||
|
|
[(only _raw-module-path id ...)
|
||
|
|
(set-union! sos
|
||
|
|
(syntax->string-set #'(id ...)))]
|
||
|
|
[(prefix prefix-id raw-module-path)
|
||
|
|
(module-exported-strings #'raw-module-path
|
||
|
|
lang
|
||
|
|
#:prefix #'prefix-id)]
|
||
|
|
[(all-except raw-module-path id ...)
|
||
|
|
(module-exported-strings #'raw-module-path
|
||
|
|
lang
|
||
|
|
#:except (syntax->string-set #'(id ...)))]
|
||
|
|
[(prefix-all-except prefix-id raw-module-path id ...)
|
||
|
|
(module-exported-strings #'raw-module-path
|
||
|
|
lang
|
||
|
|
#:prefix #'prefix-id
|
||
|
|
#:except (syntax->string-set #'(id ...)))]
|
||
|
|
[(rename raw-module-path local-id exported-id)
|
||
|
|
(begin
|
||
|
|
(unless (eq? (syntax-e #'raw-module-path) (syntax-e lang))
|
||
|
|
(set-remove! sos (->str #'exported-id)))
|
||
|
|
(set-add! sos (->str #'local-id)))]
|
||
|
|
[raw-module-path
|
||
|
|
(module-path? (syntax->datum #'raw-module-path))
|
||
|
|
(module-exported-strings #'raw-module-path
|
||
|
|
lang)]))
|
||
|
|
|
||
|
|
(define (module-exported-strings raw-module-path
|
||
|
|
lang
|
||
|
|
#:except [exceptions (set)]
|
||
|
|
#:prefix [prefix #'""])
|
||
|
|
;; NOTE: Important to run this with the correct parameterization of
|
||
|
|
;; current-namespace and current-load-relative-directory.
|
||
|
|
(define (add-exports mp)
|
||
|
|
(define-values (vars stxs) (module->exports mp))
|
||
|
|
(define orig
|
||
|
|
(for*/mutable-set ([vars+stxs (in-list (list vars stxs))]
|
||
|
|
[phases (in-list vars+stxs)]
|
||
|
|
[export (in-list (cdr phases))])
|
||
|
|
(->str (car export))))
|
||
|
|
;; If imports are from the module language, then {except rename
|
||
|
|
;; prefix}-in do NOT remove imports under the original name.
|
||
|
|
;; Otherwise they do.
|
||
|
|
(if (eq? (syntax-e raw-module-path) (syntax-e lang))
|
||
|
|
(set-union! sos orig)
|
||
|
|
(set-subtract! sos orig exceptions))
|
||
|
|
(for ([v (in-set orig)])
|
||
|
|
(set-add! sos (~a (->str prefix) v))))
|
||
|
|
|
||
|
|
;; Ignore non-external module paths: module->exports can't handle
|
||
|
|
;; them, and anyway, drracket/check-syntax will contribute
|
||
|
|
;; completion candidates for local definitions, we don't need to
|
||
|
|
;; find them here.
|
||
|
|
(syntax-case* raw-module-path (quote submod) symbolic-compare?
|
||
|
|
[(quote _) sos]
|
||
|
|
[(submod "." . _) sos]
|
||
|
|
[_ (add-exports (syntax->datum raw-module-path))]))
|
||
|
|
|
||
|
|
(handle-module stx)
|
||
|
|
sos)
|
||
|
|
|
||
|
|
(define (->str v)
|
||
|
|
(match v
|
||
|
|
[(? syntax?) (->str (syntax-e v))]
|
||
|
|
[(? symbol?) (symbol->string v)]
|
||
|
|
[(? string?) v]))
|
||
|
|
|
||
|
|
(define (syntax->string-set s)
|
||
|
|
(for/mutable-set ([s (in-syntax s)])
|
||
|
|
(->str s)))
|
||
|
|
|
||
|
|
(define (symbolic-compare? x y)
|
||
|
|
(eq? (syntax-e x) (syntax-e y)))
|
||
|
|
|
||
|
|
(module+ completions-example
|
||
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
||
|
|
(define stx
|
||
|
|
(expand
|
||
|
|
#'(module m racket/base
|
||
|
|
(module sub racket/base (void))
|
||
|
|
(require racket/require
|
||
|
|
(submod "." sub)
|
||
|
|
(except-in "../error.rkt" show-full-path-in-errors)
|
||
|
|
(prefix-in XXX: (except-in racket/file other-write-bit))
|
||
|
|
(rename-in racket/path [path-only PATH-ONLY])))))
|
||
|
|
(syntax->datum stx)
|
||
|
|
(imports stx)))
|
||
|
|
|
||
|
|
(module+ test
|
||
|
|
(require rackunit
|
||
|
|
version/utils)
|
||
|
|
;; Compare the results to namespace-mapped-symbols.
|
||
|
|
(module mod racket/base
|
||
|
|
(module sub racket/base
|
||
|
|
(define provided-by-submodule 42)
|
||
|
|
(provide provided-by-submodule))
|
||
|
|
(require (rename-in racket/path
|
||
|
|
[path-only PATH-ONLY])
|
||
|
|
(except-in racket/base println)
|
||
|
|
(rename-in racket/base
|
||
|
|
[display DISPLAY])
|
||
|
|
(prefix-in PREFIX: (only-in racket/base displayln))
|
||
|
|
(for-syntax (rename-in racket/syntax [format-id FORMAT-ID]))
|
||
|
|
(submod "." sub))
|
||
|
|
(define-namespace-anchor nsa)
|
||
|
|
(define nsms (map symbol->string
|
||
|
|
(namespace-mapped-symbols
|
||
|
|
(namespace-anchor->namespace nsa))))
|
||
|
|
(provide nsms))
|
||
|
|
(require 'mod)
|
||
|
|
(define mod/stx
|
||
|
|
(expand
|
||
|
|
#`(module mod racket/base
|
||
|
|
(module sub racket/base
|
||
|
|
(define provided-by-submodule 42)
|
||
|
|
(provide provided-by-submodule))
|
||
|
|
(require (rename-in racket/path
|
||
|
|
[path-only PATH-ONLY])
|
||
|
|
(except-in racket/base println)
|
||
|
|
(rename-in racket/base
|
||
|
|
[display DISPLAY])
|
||
|
|
(prefix-in PREFIX: (only-in racket/base displayln))
|
||
|
|
(for-syntax (rename-in racket/syntax [format-id FORMAT-ID]))
|
||
|
|
(submod "." sub))
|
||
|
|
(eprintf "I should not print!"))))
|
||
|
|
(let (;; The world according to `namespace-mapped-symbols`
|
||
|
|
[nsms (list->set nsms)]
|
||
|
|
;; The world according to our `imports`
|
||
|
|
[cs (parameterize ([current-namespace (make-base-namespace)])
|
||
|
|
(define stx (expand mod/stx))
|
||
|
|
(time (imports stx)))])
|
||
|
|
;; Test {prefix rename except}-in, keeping mind that they work
|
||
|
|
;; differently for requires that modify the module language
|
||
|
|
;; imports.
|
||
|
|
(check-false (set-member? cs "path-only")
|
||
|
|
"rename-in not from module language hides old name")
|
||
|
|
(check-true (set-member? cs "PATH-ONLY")
|
||
|
|
"rename-in not from module language has new name ")
|
||
|
|
(check-true (set-member? cs "display")
|
||
|
|
"rename-in from module language does not hide old name")
|
||
|
|
(check-true (set-member? cs "DISPLAY")
|
||
|
|
"rename-in from module language has new name")
|
||
|
|
(check-true (set-member? cs "displayln")
|
||
|
|
"prefix-in from module language does not hide old name")
|
||
|
|
(check-true (set-member? cs "PREFIX:displayln")
|
||
|
|
"prefix-in from module language is available under new name")
|
||
|
|
;; namespace-mapped-symbols will return some definitions beyond
|
||
|
|
;; those imported -- it includes {top module}-level bindings. This
|
||
|
|
;; test accounts for that with a dumb ad hoc list. (More nifty
|
||
|
|
;; would be to walk our test stx and build that list.)
|
||
|
|
;;
|
||
|
|
;; FIXME? Travis CI says this test fails prior to Racket 7.0:
|
||
|
|
;; namespace-mapped-symbols reports ~400 more symbols --
|
||
|
|
;; apparently from full racket (should be racket/base). Huh??
|
||
|
|
;; Well, _our_ results are correct. For now, let's just do the
|
||
|
|
;; test on Racket 7.0+.
|
||
|
|
(when (version<=? "7.0" (version))
|
||
|
|
(check-equal? (set-subtract nsms cs)
|
||
|
|
(set "tmp.1" "nsms" "nsa" "provided-by-submodule")
|
||
|
|
"namespace-mapped-symbols returns only a few more, non-imported definitions"))))
|
||
|
|
|
||
|
|
(module+ slow-test
|
||
|
|
;; Exercise our parsing of the #%require grammar: Try doing
|
||
|
|
;; (check-not-exn (imports stx)) on many files in the Racket
|
||
|
|
;; distribution. Grammar mistakes will raise exn:fail:syntax.
|
||
|
|
(require rackunit
|
||
|
|
racket/path
|
||
|
|
"syntax.rkt")
|
||
|
|
(define (check path)
|
||
|
|
(parameterize ([current-load-relative-directory (path-only path)]
|
||
|
|
[current-namespace (make-base-namespace)])
|
||
|
|
(file->expanded-syntax
|
||
|
|
path
|
||
|
|
(λ (stx)
|
||
|
|
(check-not-exn (λ () (imports stx))
|
||
|
|
(format "#%require grammar handles ~v" path))))))
|
||
|
|
(for* ([roots (in-list '(("racket.rkt" "typed")
|
||
|
|
("core.rkt" "typed-racket")
|
||
|
|
("main.rkt" "racket")))]
|
||
|
|
[path (in-directory
|
||
|
|
(path-only
|
||
|
|
(apply collection-file-path roots)))]
|
||
|
|
#:when (equal? #"rkt" (filename-extension path)))
|
||
|
|
(println path)
|
||
|
|
(check path)))
|