suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improved support for #lang planet (in drscheme)

Browse Source
This commit is contained in:
Robby Findler 2010-04-21 12:14:17 -04:00
parent c0c80683c9
commit 59d90b279d
8 changed files with 104 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/drscheme/private/module-language-tools.ss
View File

@ -9,6 +9,9 @@
scheme/gui/base
"drsig.ss")
(define op (current-output-port))
(define (oprintf . args) (apply fprintf op args))
(define-unit module-language-tools@
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:module-language: drscheme:module-language^]
@ -18,7 +21,7 @@
(define-local-member-name initialized? move-to-new-language)
(define-struct opt-out-toolbar-button (make-button id))
(define-struct opt-out-toolbar-button (make-button id) #:transparent)
(define opt-out-toolbar-buttons '())
(define (add-opt-out-toolbar-button make-button id)
@ -98,18 +101,18 @@
(define/public (move-to-new-language)
(let* ([port (open-input-text-editor this)]
;; info-result : (or/c #f [#lang without a known language]
;; (vector <get-info-proc>) [no #lang line, so we use the '#lang racket' info proc]
;; <get-info-proc> [the get-info proc for the program in the definitions]
[info-result (with-handlers ((exn:fail? (λ (x) #f)))
(parameterize ([current-reader-guard
(let ([old (current-reader-guard)])
(lambda (g)
(if (and (pair? g)
(eq? (car g) 'planet))
(error "#lang planet disbled")
(old g))))])
;; FIXME: do something so that we don't
;; have to disable all planet packages.
(read-language port (lambda () #f))))])
;; sometimes I get eof here, but I don't know why and can't seem to
(read-language
port
(lambda ()
;; fall back to whatever #lang racket does if
;; we don't have a #lang line present in the file
(vector (read-language (open-input-string "#lang racket"))))))])
; sometimes I get eof here, but I don't know why and can't seem to
;; make it happen outside of DrScheme
(when (eof-object? info-result)
(fprintf (current-error-port) "file ~s produces eof from read-language\n"
@ -128,10 +131,18 @@
(contract (or/c #f (listof (list/c string?
(is-a?/c bitmap%)
(-> (is-a?/c drscheme:unit:frame<%>) any))))
(info-result 'drscheme:toolbar-buttons #f)
(get-lang-name pos)
((if (vector? info-result)
(vector-ref info-result 0)
info-result)
'drscheme:toolbar-buttons #f)
(if (vector? info-result)
'hash-lang-racket
(get-lang-name pos))
'drscheme/private/module-language-tools)
(info-result 'drscheme:opt-out-toolbar-buttons '())))))))
((if (vector? info-result)
(vector-ref info-result 0)
info-result)
'drscheme:opt-out-toolbar-buttons '())))))))
(inherit get-tab)

11
collects/drscheme/private/module-language.ss
View File

@ -63,15 +63,8 @@
(let* ([defs-port (open-input-text-editor defs-text)]
[read-successfully?
(with-handlers ((exn:fail? (λ (x) #f)))
(let/ec k
(let ([orig-security (current-security-guard)])
(parameterize ([current-security-guard
(make-security-guard
orig-security
(lambda (what path modes) #t)
(lambda (what host port mode) (k #f)))])
(read-language defs-port (λ () (void)))
#t))))])
(read-language defs-port (λ () #f))
#t)])
(cond
[read-successfully?
(let* ([str (send defs-text get-text 0 (file-position defs-port))]

45
collects/planet/lang/reader.ss
View File

@ -1,19 +1,30 @@
(module reader scheme/base
(require syntax/module-reader)
#lang scheme/base
(require syntax/module-reader
"../resolver.ss")
(provide (rename-out [planet-read read]
[planet-read-syntax read-syntax]
[planet-get-info get-info]))
(provide (rename-out [planet-read read]
[planet-read-syntax read-syntax]
[planet-get-info get-info]))
(define (str->spec str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
(define-values (planet-read planet-read-syntax real-planet-get-info)
(make-meta-reader
'planet
"planet path"
str->spec
values
values
values))
(define op (current-output-port))
(define (planet-get-info inport module-path line col pos)
(parameterize ([install? #f]
[download? #f])
(real-planet-get-info inport module-path line col pos)))
(define-values (planet-read planet-read-syntax planet-get-info)
(make-meta-reader
'planet
"planet path"
(lambda (str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
values
values
values)))

28
collects/planet/planet.scrbl
View File

@ -463,6 +463,30 @@ The @schememodname[planet] module (as opposed to the reader used with
The planet collection provides configuration and utilities for using PLaneT.
@subsection{Resolver}
@defmodule[planet/resolver]
The primary purpose of this library to for @scheme[require] to find
@PLaneT packages. It also, however, provides some utilities for manipulating
the resolvers behavior.
@defproc[(resolve-planet-path [planet-path any/c]) path?]{
Returns the path where the file named by the require spec @scheme[planet-path] is located in the current installation.
}
@defparam[download? dl? boolean?]{
A parameter that controls if @PLaneT attempts to download a planet package that isn't already present.
If the package isn't present, the resolver will raise the @scheme[exn:fail:planet?] exception
instead of downloading it.
}
@defparam[install? inst? boolean?]{
A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed.
If the package isn't installed, the resolver will raise the @scheme[exn:fail:planet?] exception
instead of installing it.
}
@subsection{Client Configuration}
@defmodule[planet/config]
@ -659,6 +683,10 @@ context of a package. The others are convenience macros that
select out the relevant field, or return @scheme[#f] if the expression
appears outside the context of a PLaneT package.}
@defproc[(exn:fail:planet? [val any/c]) boolean?]{
Returns @scheme[#t] if @scheme[val] is
}
@subsection{Terse Status Updates}
@defmodule[planet/terse-info]

18
collects/planet/resolver.ss
View File

@ -212,10 +212,16 @@ subdirectory.
pkg-promise->pkg
install-pkg
get-planet-module-path/pkg
install?)
download?
install?
exn:fail:planet?
make-exn:fail:planet)
;; if #f, will not install packages and instead give an error
;; if #f, will not install packages and instead raise a exn:fail:install? error
(define install? (make-parameter #t))
;; if #f, will not download packages and instead raise a exn:fail:install? error
(define download? (make-parameter #t))
(define-struct (exn:fail:planet exn:fail) ())
;; update doc index only once for a set of installs:
(define planet-nested-install (make-parameter #f))
@ -511,6 +517,12 @@ subdirectory.
(string-append "PLaneT could not download the requested package: " s)]))
(define (download-package pkg)
(unless (download?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot download package ~s since the download? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg)))
(current-continuation-marks))))
((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet)
pkg))
@ -539,7 +551,7 @@ subdirectory.
;; installed file
(define (install-pkg pkg path maj min)
(unless (install?)
(raise (make-exn:fail
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min))

7
collects/planet/util.ss
View File

@ -41,12 +41,13 @@
unlink-all
lookup-package-by-keys
resolve-planet-path
(struct-out exn:fail:planet)
display-plt-file-structure
display-plt-archived-file
get-package-from-cache
install-pkg
pkg->download-url)
pkg->download-url
exn:fail:planet?
make-exn:fail:planet)
(provide/contract
[get-package-spec
@ -103,8 +104,6 @@
;; -- remove any existing linkage for package
;; returns void if the removal worked; raises an exception if no package existed.
(define-struct (exn:fail:planet exn:fail) ())
(define (remove-pkg owner name maj min)
(let ((p (get-installed-package owner name maj min)))
(unless p

11
collects/syntax-color/module-lexer.ss
View File

@ -12,16 +12,7 @@
[(init) (file-position p)]
[(start-line start-col start-pos) (port-next-location p)])
(let ([get-info (with-handlers ([exn:fail? (lambda (exn) 'fail)])
(parameterize ([current-reader-guard
(let ([old (current-reader-guard)])
(lambda (g)
(if (and (pair? g)
(eq? (car g) 'planet))
(error "#lang planet disbled")
(old g))))])
;; FIXME: do something so that we don't
;; have to disable all planet packages.
(read-language p (lambda () #f))))]
(read-language p (lambda () #f)))]
[sync-ports (lambda ()
(read-bytes (- (file-position p) init) in))])
(cond

2
collects/syntax/module-reader.ss
View File

@ -216,7 +216,7 @@
#:read-spec
[read-spec
(lambda (in)
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)])
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) ;; if this changes, the regexp in planet's lang/reader.ss must also change
(and spec (let ([s (cadr spec)])
(if (equal? s "") #f s)))))])
(define (get in export-sym src line col pos spec-as-stx? mk-fail-thunk)