271 lines
11 KiB
Racket
271 lines
11 KiB
Racket
|
#lang at-exp racket/base
|
||
|
|
|
||
|
|
(require racket/contract
|
||
|
|
racket/file
|
||
|
|
racket/format
|
||
|
|
racket/function
|
||
|
|
racket/list
|
||
|
|
racket/match
|
||
|
|
syntax/modread
|
||
|
|
racket/path
|
||
|
|
syntax/parse
|
||
|
|
syntax/strip-context
|
||
|
|
syntax/stx
|
||
|
|
(only-in "error.rkt" display-exn)
|
||
|
|
"mod.rkt"
|
||
|
|
(only-in "util.rkt" display-commented))
|
||
|
|
|
||
|
|
(provide dynamic-require/some-namespace)
|
||
|
|
|
||
|
|
;; A composition of dynamic-require and module->namespace that tries
|
||
|
|
;; to tolerate syntax errors. It tries to return a namespace with at
|
||
|
|
;; least some identifiers from the file -- such as from module
|
||
|
|
;; languages, requires, and definitions.
|
||
|
|
;;
|
||
|
|
;; Motivation:
|
||
|
|
;;
|
||
|
|
;; https://github.com/greghendershott/racket-mode/issues/272
|
||
|
|
;;
|
||
|
|
;; You're working in #lang racket/base. You're partway through writing
|
||
|
|
;; a some expression, and realize you need to add (say)
|
||
|
|
;; with-module-reading-parameterization. You add syntax/modread to
|
||
|
|
;; your require.
|
||
|
|
;;
|
||
|
|
;; Now, you want to type with-m and hit TAB to complete. Plus after
|
||
|
|
;; that, you might want to C-. a.k.a. M-x racket-describe to read
|
||
|
|
;; docs.
|
||
|
|
;;
|
||
|
|
;; But you need to re-run, first, for the new require to take effect
|
||
|
|
;; and make the syntax/modread exports available.
|
||
|
|
;;
|
||
|
|
;; But if you re-run, your half-written expression results in a syntax
|
||
|
|
;; or runtime error. Now your REPL is just an empty racket/base.
|
||
|
|
;;
|
||
|
|
;; Annoying!
|
||
|
|
;;
|
||
|
|
;; Strategy: When dynamic-require fails, try again using a custom load
|
||
|
|
;; handler that rewrites the file -- "distill" it to a skeleton of
|
||
|
|
;; module forms, requires, and define-values. Try again using that.
|
||
|
|
;;
|
||
|
|
;; Note that it's important for the skeleton to include submodules,
|
||
|
|
;; because racket-mode lets you "enter" a submodule and work with
|
||
|
|
;; identifiers inside it (and only inside it).
|
||
|
|
|
||
|
|
(define is-skeleton
|
||
|
|
"[Due to errors, REPL is just module language, requires, and stub definitions]")
|
||
|
|
(define is-base
|
||
|
|
"[Due to errors, REPL is just racket/base]")
|
||
|
|
|
||
|
|
;; A composition of dynamic-require and module->namespace, but which
|
||
|
|
;; tries to tolerate errors in the source file and return _some_
|
||
|
|
;; namespace more useful than racket/base (if possible).
|
||
|
|
(define/contract (dynamic-require/some-namespace mod retry-as-skeletal?)
|
||
|
|
(-> mod? boolean? namespace?)
|
||
|
|
(parameterize ([current-load-relative-directory (mod-dir mod)]
|
||
|
|
[current-directory (mod-dir mod)])
|
||
|
|
(cond [(normal mod) => values]
|
||
|
|
[(and retry-as-skeletal?
|
||
|
|
(skeletal mod)) => (λ (ns)
|
||
|
|
(display-commented is-skeleton)
|
||
|
|
ns)]
|
||
|
|
[else (display-commented is-base)
|
||
|
|
(make-base-namespace)])))
|
||
|
|
|
||
|
|
(define/contract (normal mod)
|
||
|
|
(-> mod? (or/c #f namespace?))
|
||
|
|
(with-handlers ([exn:fail? (λ (e) (display-exn e) #f)])
|
||
|
|
(dynamic-require (mod-rmp mod) #f)
|
||
|
|
(module->namespace (mod-rmp mod))))
|
||
|
|
|
||
|
|
(define/contract (skeletal mod)
|
||
|
|
(-> mod? (or/c #f namespace?))
|
||
|
|
(with-handlers ([exn:fail? (const #f)]) ;don't show errors again
|
||
|
|
(parameterize ([current-load (make-load mod)]
|
||
|
|
;; Module is cached in old namespace, so for `load`
|
||
|
|
;; to be called, we need a fresh namespace.
|
||
|
|
[current-namespace (make-base-namespace)])
|
||
|
|
(dynamic-require (mod-rmp mod) #f)
|
||
|
|
(module->namespace (mod-rmp mod)))))
|
||
|
|
|
||
|
|
(define/contract (make-load mod)
|
||
|
|
(-> mod? any)
|
||
|
|
(define original-load (current-load))
|
||
|
|
(define special-path (build-path (mod-dir mod) (mod-file mod)))
|
||
|
|
(λ (path module-name)
|
||
|
|
(if (equal? path special-path)
|
||
|
|
(eval (skeleton (read-module-file path)))
|
||
|
|
(original-load path module-name))))
|
||
|
|
|
||
|
|
(define (read-module-file file) ;Path-String -> Syntax
|
||
|
|
(with-module-reading-parameterization
|
||
|
|
(λ ()
|
||
|
|
(parameterize ([read-accept-compiled #f])
|
||
|
|
(with-input-from-file file read-syntax)))))
|
||
|
|
|
||
|
|
(define no-op-expr #'(void))
|
||
|
|
(define no-op-def-val #''|Due to errors in source file, this value is from a "stub" define-values|)
|
||
|
|
|
||
|
|
(define (skeleton stx) ;Syntax -> Syntax
|
||
|
|
;; We got here because `stx` has either a syntax error or a runtime
|
||
|
|
;; error. If it has a syntax error, we can't `expand` it as whole.
|
||
|
|
;; Let's try to distill it to a skeleton of things that create
|
||
|
|
;; runtime, module-level bidings: requires and defines.
|
||
|
|
;;
|
||
|
|
;; To get #%require and define-values, we want to work with
|
||
|
|
;; fully-expanded syntax as much as possible. But we have to catch
|
||
|
|
;; syntax errors and replace each with #'(void). Also we want to
|
||
|
|
;; walk submodule forms for their bindings, but we can't expand a
|
||
|
|
;; submodule forms in isolation (that's a syntax error).
|
||
|
|
;;
|
||
|
|
;; So, the idea is to preserve the nested modules skeleton, and only
|
||
|
|
;; try to expand each of their module-level expressions to discover
|
||
|
|
;; bindings.
|
||
|
|
;;
|
||
|
|
;; Our final result should, as a whole, work with (eval (expand)).
|
||
|
|
(strip-context
|
||
|
|
;; Unlike expand-syntax-to-top-form, expand-to-top-form does
|
||
|
|
;; namespace-syntax-introduce before expanding to top form.
|
||
|
|
(let recur ([stx (expand-to-top-form stx)])
|
||
|
|
(syntax-parse stx
|
||
|
|
#:literal-sets (kernel-literals)
|
||
|
|
#:datum-literals (#%module-begin module+)
|
||
|
|
;; Note: A #lang file has #%module-begin even on initial read
|
||
|
|
;; and without calling `expand`. However, a (module) expression
|
||
|
|
;; file -- even when using with-module-reading-parameterization
|
||
|
|
;; -- doesn't. That only gets added by `expand`. But we can't
|
||
|
|
;; use `expand`. Anyway, it hardly matters as we're going to
|
||
|
|
;; remove everything interesting that a #%module-begin might
|
||
|
|
;; transform (IIUC). Just treat #%module-begin as begin.
|
||
|
|
[((~and mod (~or module module*)) name:id lang:expr . es)
|
||
|
|
#`(mod name lang . #,(stx-map recur #'es))]
|
||
|
|
[(#%module-begin . es)
|
||
|
|
#`(begin . #,(stx-map recur #'es))]
|
||
|
|
[(module+ name:id . es)
|
||
|
|
#`(module+ name . #,(stx-map recur #'es))]
|
||
|
|
[_
|
||
|
|
(let ([stx (with-handlers ([exn:fail:syntax? (const no-op-expr)])
|
||
|
|
(expand stx))])
|
||
|
|
(syntax-parse stx
|
||
|
|
#:literal-sets (kernel-literals)
|
||
|
|
[(begin . es) #`(begin . #,(stx-map recur #'es))]
|
||
|
|
[(#%require . _) stx]
|
||
|
|
[(define-values (id ...) . _) #`(define-values (id ...)
|
||
|
|
(values
|
||
|
|
#,@(stx-map (const no-op-def-val)
|
||
|
|
#'(id ...))))]
|
||
|
|
[_ no-op-expr]))]))))
|
||
|
|
|
||
|
|
(module+ test
|
||
|
|
(require rackunit
|
||
|
|
racket/set
|
||
|
|
version/utils)
|
||
|
|
|
||
|
|
;; A example of the transformation we do.
|
||
|
|
;;
|
||
|
|
;; Note: Prior to Racket 6.3, expansion of `require` with
|
||
|
|
;; non-existent modules seems to be a syntax error. So in this test,
|
||
|
|
;; use modules that actually exist in minimal Racket.
|
||
|
|
(check-equal? (syntax->datum
|
||
|
|
(skeleton
|
||
|
|
#'(module m racket/base
|
||
|
|
(#%module-begin
|
||
|
|
(require racket/pretty
|
||
|
|
racket/list)
|
||
|
|
(if) ;stx err
|
||
|
|
(/ 1 0) ;runtime err
|
||
|
|
(define foo 42)
|
||
|
|
(define-values (bar baz) (values 43 44))
|
||
|
|
(define (f x) (+ x 1))
|
||
|
|
(module* m #f
|
||
|
|
(require net/url)
|
||
|
|
(if) ;stx err
|
||
|
|
(/ 1 0)) ;runtime err
|
||
|
|
(module+ test
|
||
|
|
(require rackunit)
|
||
|
|
(if)) ;stx err
|
||
|
|
(module m typed/racket/base
|
||
|
|
(#%module-begin
|
||
|
|
(require racket/function)
|
||
|
|
(define id 42)
|
||
|
|
(if))))))) ;stx err
|
||
|
|
(let ([no-op-expr (syntax->datum no-op-expr)]
|
||
|
|
[no-op-def-val (syntax->datum no-op-def-val)])
|
||
|
|
`(module m racket/base
|
||
|
|
(begin
|
||
|
|
(begin (#%require racket/pretty) (#%require racket/list))
|
||
|
|
,no-op-expr
|
||
|
|
,no-op-expr
|
||
|
|
(define-values (foo) (values ,no-op-def-val))
|
||
|
|
(define-values (bar baz) (values ,no-op-def-val ,no-op-def-val))
|
||
|
|
(define-values (f) (values ,no-op-def-val))
|
||
|
|
(module* m #f
|
||
|
|
(#%require net/url)
|
||
|
|
(void)
|
||
|
|
(void))
|
||
|
|
(module+ test
|
||
|
|
(#%require rackunit)
|
||
|
|
,no-op-expr)
|
||
|
|
(module m typed/racket/base
|
||
|
|
(begin
|
||
|
|
(#%require racket/function)
|
||
|
|
(define-values (id) (values ,no-op-def-val))
|
||
|
|
,no-op-expr))))))
|
||
|
|
|
||
|
|
;; Helpers to write text or sexpr to a tempory .rkt file, then run
|
||
|
|
;; through dynamic-require/some-namespace and get the
|
||
|
|
;; namespace-mapped-symbols.
|
||
|
|
|
||
|
|
(define/contract (call-with-temporary-file v proc)
|
||
|
|
(-> any/c (-> mod? any/c) any/c)
|
||
|
|
(define file #f)
|
||
|
|
(dynamic-wind
|
||
|
|
(λ ()
|
||
|
|
(set! file (make-temporary-file "call-with-temporary-file-~a.rkt"))
|
||
|
|
(call-with-output-file file #:exists 'replace
|
||
|
|
(λ (out)
|
||
|
|
(cond [(string? v) (display v out)]
|
||
|
|
[else (write v out)]))))
|
||
|
|
(λ () (proc (->mod/existing file)))
|
||
|
|
(λ () (delete-file file))))
|
||
|
|
|
||
|
|
(define/contract (syms mod)
|
||
|
|
(-> mod? (listof symbol?))
|
||
|
|
(namespace-mapped-symbols
|
||
|
|
(parameterize ([current-namespace (make-base-empty-namespace)])
|
||
|
|
(dynamic-require/some-namespace mod #t))))
|
||
|
|
|
||
|
|
(define (do v)
|
||
|
|
(define op (open-output-string))
|
||
|
|
(define result (parameterize ([current-error-port op])
|
||
|
|
(call-with-temporary-file v syms)))
|
||
|
|
(check-match (get-output-string op)
|
||
|
|
(regexp (string-append (regexp-quote is-skeleton) "\n$")))
|
||
|
|
result)
|
||
|
|
|
||
|
|
;; Despite a syntax error and a runtime error, a binding provided by
|
||
|
|
;; a require is available in the namespace in both:
|
||
|
|
|
||
|
|
;; (a) A #lang file:
|
||
|
|
(check-not-false
|
||
|
|
(memq 'pretty-print (do @~a{#lang racket/base
|
||
|
|
(if)
|
||
|
|
(require racket/pretty)})))
|
||
|
|
|
||
|
|
;; (b) A module expression file:
|
||
|
|
(check-not-false
|
||
|
|
(memq 'pretty-print (do `(module m racket/base
|
||
|
|
(if)
|
||
|
|
(require racket/pretty)))))
|
||
|
|
|
||
|
|
;; Requiring exactly 1 binding adds exactly that symbol to the
|
||
|
|
;; namespace:
|
||
|
|
(check-equal? (set-subtract
|
||
|
|
(list->set
|
||
|
|
(do `(module m racket/base
|
||
|
|
(/ 1 0)
|
||
|
|
(require (only-in racket/pretty pretty-print)))))
|
||
|
|
(list->set
|
||
|
|
(do `(module n racket/base
|
||
|
|
(/ 1 0)))))
|
||
|
|
(set 'pretty-print)))
|