diff --git a/collects/drscheme/private/language-object-contract.ss b/collects/drscheme/private/language-object-contract.ss index 3884ad25fc..cc44277130 100644 --- a/collects/drscheme/private/language-object-contract.ss +++ b/collects/drscheme/private/language-object-contract.ss @@ -4,71 +4,93 @@ scribble/srcdoc scheme/class scheme/gui/base - scheme/contract) + scheme/contract + scribblings/tools/recon) (require/doc scheme/base scribble/manual) +(require (for-meta 2 scheme/base)) + +(provide language-object-abstraction) + (define-syntax (language-object-abstraction stx) (syntax-case stx () - [(_ id) - (with-syntax ([ctc - #'(object-contract - (config-panel (-> (is-a?/c area-container<%>) - (case-> (-> any/c void?) - (-> any/c)))) - (create-executable (-> any/c - (or/c (is-a?/c dialog%) (is-a?/c frame%)) - path? - void?)) - (default-settings (-> any/c)) - (default-settings? (-> any/c boolean?)) - (order-manuals (-> (listof bytes?) - (values (listof bytes?) boolean?))) - (front-end/complete-program (-> input-port? - any/c - (-> any/c))) - (front-end/interaction (-> input-port? - any/c - (-> any/c))) - (get-language-name (-> string?)) - (get-language-numbers (-> (cons/c number? (listof number?)))) - (get-language-position (-> (cons/c string? (listof string?)))) - (get-language-url (-> (or/c false/c string?))) - (get-one-line-summary (-> string?)) - (get-comment-character (-> (values string? char?))) - (get-style-delta - (-> (or/c false/c - (is-a?/c style-delta%) - (listof - (list/c (is-a?/c style-delta%) - number? - number?))))) - (marshall-settings (-> any/c printable/c)) - (on-execute (-> any/c (-> (-> any) any) any)) - (render-value (-> any/c - any/c - output-port? - void?)) - (render-value/format (-> any/c - any/c - output-port? - (or/c number? (symbols 'infinity)) - any)) - (unmarshall-settings (-> printable/c any)) - - - (capability-value (-> symbol? any)) - - #; - (capability-value - (->d ([s (and/c symbol? - drscheme:language:capability-registered?)]) - () - [res (drscheme:language:get-capability-contract s)])))]) - #'(begin - (define id ctc) - (provide/doc - (thing-doc id - contract? - @{@schemeblock[ctc]}))))])) - -(language-object-abstraction drscheme:language:object/c) + [(_ id provide?) + (let-syntax ([save-srcloc + (λ (s) + (define-struct sloc (inside loc) #:prefab) + (syntax-case s () + [(_ arg) + (with-syntax ([ans + (let loop ([s #'arg]) + (cond + [(syntax? s) + (let ([loc (vector (syntax-source s) + (syntax-line s) + (syntax-column s) + (syntax-position s) + (syntax-span s))]) + (make-sloc (loop (syntax-e s)) loc))] + [(pair? s) (cons (loop (car s)) (loop (cdr s)))] + [else s]))]) + #'ans)]))]) + (let* ([ctc + (save-srcloc + (object-contract + (config-panel (-> (is-a?/c area-container<%>) + (case-> (-> any/c void?) + (-> any/c)))) + (create-executable (-> any/c + (or/c (is-a?/c dialog%) (is-a?/c frame%)) + path? + void?)) + (default-settings (-> any/c)) + (default-settings? (-> any/c boolean?)) + (order-manuals (-> (listof bytes?) + (values (listof bytes?) boolean?))) + (front-end/complete-program (-> input-port? + any/c + (-> any/c))) + (front-end/interaction (-> input-port? + any/c + (-> any/c))) + (get-language-name (-> string?)) + (get-language-numbers (-> (cons/c number? (listof number?)))) + (get-language-position (-> (cons/c string? (listof string?)))) + (get-language-url (-> (or/c false/c string?))) + (get-one-line-summary (-> string?)) + (get-comment-character (-> (values string? char?))) + (get-style-delta + (-> (or/c false/c + (is-a?/c style-delta%) + (listof + (list/c (is-a?/c style-delta%) + number? + number?))))) + (marshall-settings (-> any/c printable/c)) + (on-execute (-> any/c (-> (-> any) any) any)) + (render-value (-> any/c + any/c + output-port? + void?)) + (render-value/format (-> any/c + any/c + output-port? + (or/c number? (symbols 'infinity)) + any)) + (unmarshall-settings (-> printable/c any)) + + (capability-value + (->d ([s (and/c symbol? + drscheme:language:get-capability-contract)]) + () + [res (drscheme:language:capability-registered? s)]))))]) + #`(begin + (define id (reconstitute #,ctc provide?)) + #,@(if (syntax-e #'provide?) + (list + #`(require/doc "recon.ss") + #`(provide/doc + (thing-doc id + contract? + ((reconstitute (schemeblock #,ctc) provide?))))) + '()))))])) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index 44f7e8105e..f59afc7178 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -198,16 +198,22 @@ (get-successful-tools)))) -;;; ;; ; ; ;; -; ; ; ; -; ; ; ; -; ;;; ;;;; ;;;; ; ;;; ; ;;; ;;; ;;; ;;; ; ;; ;;; -; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; -; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;; ;;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; -;;;;;; ;;; ;;; ; ;;; ; ; ;;;;; ;;; ;; ; ;;; ;; ;; ;;; -; +; +; +; +; ;;;; ;;;; ;; ;; ;;;; +; ;;;; ;;;; ;; ;; ;;;; +; ;;;; ;;;; ;;;;;;; ;;;;;;; ;; ;;;; ;;; ;;; ;;; ;;;; ;;;; ;;; ;;; +; ;;;; ;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;; ;;;;;;;;; ;;; ;;; ;;;;;; ;;;; ;;; ;;;;; +; ;;;; ;;;;;;;; ;;;; ;;;;;;;;; ;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;;; ;;;;;;; ;;;; ;; +; ;;;; ;;;; ;;; ;;;;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;; ;;;;;;; ;;;;;;; +; ;;;; ;;;;;;;; ;; ;;;; ;;;;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;; ;;;;;;;; ;;;; ;;; ;;;;; +; ;;;; ;;;;;; ;;;;;;;; ;;;;;;;; ;; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;; ;;;;;; +; ;;;; ;;;; ;; ;;;; ;;;;;;; ;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; +; ;; +; +; + ;; load/invoke-tool : installed-tool -> void @@ -315,6 +321,7 @@ ;; invokes the tools and returns the two phase thunks. (define (invoke-tool unit tool-name) (define-unit-binding unit@ unit (import drscheme:tool^) (export drscheme:tool-exports^)) + (language-object-abstraction drscheme:language:object/c #f) (wrap-tool-inputs (let () (define-values/invoke-unit unit@ diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index a9bf5837e9..6f4f5f8744 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -39,8 +39,7 @@ all of the names in the tools library, for use defining keybindings #'((drscheme:unit:get-program-editor-mixin) a ...)] [_ #'(drscheme:unit:get-program-editor-mixin)])) -(provide drscheme:language:object/c) - +(language-object-abstraction drscheme:language:object/c #t) (provide/doc diff --git a/collects/scribblings/drscheme/extending.scrbl b/collects/scribblings/drscheme/extending.scrbl index c3c1549b7f..3e755d4d0e 100644 --- a/collects/scribblings/drscheme/extending.scrbl +++ b/collects/scribblings/drscheme/extending.scrbl @@ -104,7 +104,7 @@ For more examples, see the @filepath{htdp} sub-collection in the @; ---------------------------------------------------------------------- -@section{Environment Variables} +@section[#:tag "environment-variables"]{Environment Variables} Several environment variables can affect DrScheme's behavior: diff --git a/collects/scribblings/tools/recon.ss b/collects/scribblings/tools/recon.ss new file mode 100644 index 0000000000..c73eb69166 --- /dev/null +++ b/collects/scribblings/tools/recon.ss @@ -0,0 +1,20 @@ +#lang scheme/base +(require (for-syntax scheme/base)) +(provide reconstitute) + +(begin-for-syntax + (define-struct sloc (inside loc) #:omit-define-syntaxes #:prefab)) + +(define-syntax (reconstitute orig-stx) + (syntax-case orig-stx () + [(_ arg src) + (let loop ([stx #'arg]) + (cond + [(syntax? stx) (datum->syntax stx (loop (syntax-e stx)))] + [(pair? stx) (cons (loop (car stx)) (loop (cdr stx)))] + [(sloc? stx) + (printf "reconstitute ~s\n" (syntax->datum (sloc-loc stx))) + (datum->syntax #'src + (loop (syntax-e (sloc-inside stx))) + (syntax->datum (sloc-loc stx)))] + [else stx]))])) \ No newline at end of file diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 98f8b529bc..7627441506 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -16,12 +16,6 @@ @(defmodule drscheme/tool-lib) -@bold{TODO} - -@itemize{@item{contract for capability-value method is wrong (commented out version is right, but has circular dependencies)}} - ----------------------------------------------------------------------------------------------------- - @bold{This Manual} This manual describes DrScheme's tools interface. It assumes @@ -29,9 +23,9 @@ familiarity with PLT Scheme, as described in @(other-manual '(lib "scribblings/guide/guide.scrbl")), DrScheme, as described in -@(other-manual '(lib "drscheme/drscheme.scrbl")), +@(other-manual '(lib "scribblings/drscheme/drscheme.scrbl")), and the Framework, as described in -@(other-manual '(lib "framework/framework.scrbl")). +@(other-manual '(lib "scribblings/framework/framework.scrbl")). @table-of-contents[] @@ -385,7 +379,7 @@ implements that method before overriding it: ] To help test your tool, use the -@seclink["environment-variables-in-drscheme-manual"]{@tt{PLTONLYTOOL}} +@seclink["environment-variables" #:doc '(lib "scribblings/drscheme/extending.scrbl")]{@tt{PLTONLYTOOL}} environment variable to load it in isolation. @section{Creating New Kinds of DrScheme Frames}