From 6f25855872346e3f6b0ebc9e5fd2ba1ea389b7de Mon Sep 17 00:00:00 2001 From: Leif Andersen Date: Mon, 3 Dec 2018 15:22:12 -0500 Subject: [PATCH 1/3] Update 'definition-text-surrogate to accept lists Before a language's get-info function was expected to return a module-path? (or #f) for 'definitions-text-surrogate. Now a list is also acceptable, which can be used for meta-language's that combine their surrogate with the base language they are extending. --- .../drracket/private/in-irl-namespace.rkt | 33 ++++++++++++++----- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/drracket/drracket/private/in-irl-namespace.rkt b/drracket/drracket/private/in-irl-namespace.rkt index 9ebf41435..b0d0d2181 100644 --- a/drracket/drracket/private/in-irl-namespace.rkt +++ b/drracket/drracket/private/in-irl-namespace.rkt @@ -55,13 +55,30 @@ (add-contract 'definitions-text-surrogate (key->contract 'definitions-text-surrogate) (language-get-info 'definitions-text-surrogate #f)))) - (and surrogate-module - (new (add-contract 'definitions-text-surrogate - (implementation?/c - ;; the framework should be shared in the namespace - ;; with this module by the time we get here - (dynamic-require 'framework 'racket:text-mode<%>)) - (dynamic-require surrogate-module 'surrogate%))))) + (cond [(list? surrogate-module) + (new (let* ([surrogate-module (reverse surrogate-module)]) + (for/fold ([base (add-contract 'definitions-text-surrogate + (implementation?/c + (dynamic-require 'framework 'racket:text-mode<%>)) + (dynamic-require (car surrogate-module) 'surrogate%))]) + ([mix (in-list (cdr surrogate-module))]) + (define mixin + (add-contract 'definitions-text-surrogate + (-> + (implementation?/c + (dynamic-require 'framework 'racket:text-mode<%>)) + (implementation?/c + (dynamic-require 'framework 'racket:text-mode<%>))) + (dynamic-require mix 'surrogate%))) + (mixin base))))] + [surrogate-module + (new (add-contract 'definitions-text-surrogate + (implementation?/c + ;; the framework should be shared in the namespace + ;; with this module by the time we get here + (dynamic-require 'framework 'racket:text-mode<%>)) + (dynamic-require surrogate-module 'surrogate%)))] + [else #f])) (define-logger drracket-language) @@ -151,7 +168,7 @@ ;; is for backwards compatibility; they are copied) (define (key->contract key) (case key - [(definitions-text-surrogate) (or/c #f module-path?)] + [(definitions-text-surrogate) (or/c #f (non-empty-listof module-path?) module-path?)] [(color-lexer) ;; the contract here is taken care of inside module-lexer any/c] From 53e29a52899c8b53c11c9d0b3f0b4d7a18be3085 Mon Sep 17 00:00:00 2001 From: Leif Andersen Date: Mon, 3 Dec 2018 15:52:10 -0500 Subject: [PATCH 2/3] Update docs. --- drracket/scribblings/tools/lang-tools.scrbl | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/drracket/scribblings/tools/lang-tools.scrbl b/drracket/scribblings/tools/lang-tools.scrbl index ae6fca073..3c85f0a61 100644 --- a/drracket/scribblings/tools/lang-tools.scrbl +++ b/drracket/scribblings/tools/lang-tools.scrbl @@ -259,14 +259,21 @@ controlled extension has been added to DrRacket. calls @racket[read-language]'s @racket[get-info] procedure with @racket['definitions-text-surrogate] and expects it to return a value matching the contract - @racket[(or/c #f module-path?)], which is then passed to + @racket[(or/c #f (non-empty-listof module-path?) module-path?)]. + When given a single @racket[module-path?], it is then passed to @racket[dynamic-require] together with @racket['surrogate%]. The result is expected to be a class implementing the interface @racket[racket:text-mode<%>] (presumably derived from @racket[racket:text-mode%]. That mode is installed into the definitions text, where it can change its behavior by changing how is responds to any of the methods - in the mode. } + in the mode. When given list of @racket[module-path?]s, each element is also + passed to @racket[dynamic-require] with @racket['surrogate%]. The last element + must provide a class as described above. The remaining elements + provide mixins that return a class implementing the @racket[racket:text-mode<%>] + interface. DrRacket traverses this list to generate the surrogate for the + definitions text.} + One consequence of this power is that errors that happen during the dynamic extent of calls into the mode are not From 48ed79497a87a04037ba3d3513b3fc8143c078dc Mon Sep 17 00:00:00 2001 From: Leif Andersen Date: Tue, 4 Dec 2018 13:32:53 -0500 Subject: [PATCH 3/3] Split key into definitions-text-surrogate-list This is because a list can be a valid module path, which made the (or/c #f module-path? (listof module-path?)) contract conflict with itself. Now DrRacket defaults to getting a list, and falls back to a single module-path? if none is provided. --- .../drracket/private/in-irl-namespace.rkt | 62 +++++++++++-------- .../private/insulated-read-language.rkt | 9 ++- .../private/module-language-tools.rkt | 2 +- drracket/drracket/tool-lib.rkt | 3 +- drracket/scribblings/tools/lang-tools.scrbl | 41 +++++++----- 5 files changed, 73 insertions(+), 44 deletions(-) diff --git a/drracket/drracket/private/in-irl-namespace.rkt b/drracket/drracket/private/in-irl-namespace.rkt index b0d0d2181..039e3e060 100644 --- a/drracket/drracket/private/in-irl-namespace.rkt +++ b/drracket/drracket/private/in-irl-namespace.rkt @@ -14,6 +14,7 @@ get-read-language-last-position/inside get-read-language-name/inside get-insulated-module-lexer/inside + get-definitions-text-surrogate-list/inside get-definitions-text-surrogate/inside get-submit-predicate/inside set-irl-mcli-vec!/inside @@ -49,36 +50,46 @@ (set! module-lexer (waive-option (dynamic-require 'syntax-color/module-lexer 'module-lexer)))) module-lexer) +(define (get-definitions-text-surrogate-list/inside) + (define surrogate-modules + (and language-get-info + (or + (add-contract 'definitions-text-surrogate-list + (key->contract 'definitions-text-surrogate-list) + (language-get-info 'definitions-text-surrogate-list #f))))) + (or + (and surrogate-modules + (not (null? surrogate-modules)) + (new (let* ([surrogate-modules (reverse surrogate-modules)]) + (for/fold ([base (add-contract 'definitions-text-surrogate-list + (implementation?/c + (dynamic-require 'framework 'racket:text-mode<%>)) + (dynamic-require (car surrogate-modules) 'surrogate%))]) + ([mix (in-list (cdr surrogate-modules))]) + (define mixin + (add-contract 'definitions-text-surrogate-list + (-> + (implementation?/c + (dynamic-require 'framework 'racket:text-mode<%>)) + (implementation?/c + (dynamic-require 'framework 'racket:text-mode<%>))) + (dynamic-require mix 'surrogate%))) + (mixin base))))) + (get-definitions-text-surrogate/inside))) + (define (get-definitions-text-surrogate/inside) (define surrogate-module (and language-get-info (add-contract 'definitions-text-surrogate (key->contract 'definitions-text-surrogate) (language-get-info 'definitions-text-surrogate #f)))) - (cond [(list? surrogate-module) - (new (let* ([surrogate-module (reverse surrogate-module)]) - (for/fold ([base (add-contract 'definitions-text-surrogate - (implementation?/c - (dynamic-require 'framework 'racket:text-mode<%>)) - (dynamic-require (car surrogate-module) 'surrogate%))]) - ([mix (in-list (cdr surrogate-module))]) - (define mixin - (add-contract 'definitions-text-surrogate - (-> - (implementation?/c - (dynamic-require 'framework 'racket:text-mode<%>)) - (implementation?/c - (dynamic-require 'framework 'racket:text-mode<%>))) - (dynamic-require mix 'surrogate%))) - (mixin base))))] - [surrogate-module - (new (add-contract 'definitions-text-surrogate - (implementation?/c - ;; the framework should be shared in the namespace - ;; with this module by the time we get here - (dynamic-require 'framework 'racket:text-mode<%>)) - (dynamic-require surrogate-module 'surrogate%)))] - [else #f])) + (and surrogate-module + (new (add-contract 'definitions-text-surrogate + (implementation?/c + ;; the framework should be shared in the namespace + ;; with this module by the time we get here + (dynamic-require 'framework 'racket:text-mode<%>)) + (dynamic-require surrogate-module 'surrogate%))))) (define-logger drracket-language) @@ -168,7 +179,8 @@ ;; is for backwards compatibility; they are copied) (define (key->contract key) (case key - [(definitions-text-surrogate) (or/c #f (non-empty-listof module-path?) module-path?)] + [(definitions-text-surrogate) (or/c #f module-path?)] + [(definitions-text-surrogate-list) (or/c #f (listof module-path?))] [(color-lexer) ;; the contract here is taken care of inside module-lexer any/c] diff --git a/drracket/drracket/private/insulated-read-language.rkt b/drracket/drracket/private/insulated-read-language.rkt index 5733006d8..8ef123e5e 100644 --- a/drracket/drracket/private/insulated-read-language.rkt +++ b/drracket/drracket/private/insulated-read-language.rkt @@ -37,7 +37,8 @@ Will not work with the definitions text surrogate interposition that 'drscheme:opt-out-toolbar-buttons 'drracket:opt-in-toolbar-buttons 'color-lexer - 'definitions-text-surrogate)) + 'definitions-text-surrogate + 'definitions-text-surrogate-list)) (provide (contract-out @@ -68,6 +69,7 @@ Will not work with the definitions text surrogate interposition that [get-insulated-module-lexer (-> irl? (procedure-arity-includes/c 3))] [get-definitions-text-surrogate (-> irl? (or/c object? #f))] + [get-definitions-text-surrogate-list (-> irl? (or/c object? #f))] [set-irl-mcli-vec! (-> irl? (or/c mcli? #f) void?)] [get-insulated-submit-predicate (-> irl? (or/c #f (procedure-arity-includes/c 2)))] @@ -126,6 +128,11 @@ Will not work with the definitions text surrogate interposition that (λ () #f) 'get-definitions-text-surrogate/inside)) +(define (get-definitions-text-surrogate-list an-irl) + (call-irl-proc an-irl + (λ () #f) + 'get-definitions-text-surrogate-list/inside)) + (define mcli? (vector/c module-path? symbol? any/c #:flat? #t)) (define (get-insulated-submit-predicate an-irl) (define submit-predicate diff --git a/drracket/drracket/private/module-language-tools.rkt b/drracket/drracket/private/module-language-tools.rkt index 7e22a53bf..c7efb17f7 100644 --- a/drracket/drracket/private/module-language-tools.rkt +++ b/drracket/drracket/private/module-language-tools.rkt @@ -308,7 +308,7 @@ (clear-things-out) - (define mode (or (get-definitions-text-surrogate the-irl) + (define mode (or (get-definitions-text-surrogate-list the-irl) (new racket:text-mode%))) (send mode set-get-token (get-insulated-module-lexer the-irl)) (set-surrogate mode) diff --git a/drracket/drracket/tool-lib.rkt b/drracket/drracket/tool-lib.rkt index a5d88ca4e..c7be0a1aa 100644 --- a/drracket/drracket/tool-lib.rkt +++ b/drracket/drracket/tool-lib.rkt @@ -1167,7 +1167,8 @@ all of the names in the tools library, for use defining keybindings Note that the @racket[_surrogate] field of the mode corresponding to the module language does not take into account the - @language-info-ref[definitions-text-surrogate], so it + @language-info-ref[definitions-text-surrogate] or the + @language-info-ref[definitions-text-surrogate-list], so it may not be the actual class used directly in DrRacket, even when the mode is active. diff --git a/drracket/scribblings/tools/lang-tools.scrbl b/drracket/scribblings/tools/lang-tools.scrbl index 3c85f0a61..28ba19cd5 100644 --- a/drracket/scribblings/tools/lang-tools.scrbl +++ b/drracket/scribblings/tools/lang-tools.scrbl @@ -255,25 +255,34 @@ easily controlled in the case of errors, using the definitions text surrogate only until that more easily controlled extension has been added to DrRacket. -@language-info-def[definitions-text-surrogate]{ DrRacket - calls @racket[read-language]'s @racket[get-info] procedure - with @racket['definitions-text-surrogate] and expects it to +@language-info-def[definitions-text-surrogate-list]{ + DrRacket calls @racket[read-language]'s @racket[get-info] + procedure with @racket['definitions-text-surrogate-list] and + expects it to return a value matching the contract + @racket[(or/c #f (listof module-path?))]; each element is + also passed to @racket[dynamic-require] with + @racket['surrogate%]. The last element must provide a class + implementing the interface @racket[racket:text-mode<%>] + (presumably derived from @racket[racket:text-mode%]. The + remaining elements provide mixins that return a class + implementing the @racket[racket:text-mode<%>] interface. + DrRacket traverses this list to generate the surrogate for + the definitions text. That mode is installed into the + definitions text, where it can change its behavior by + changing how is responds to any of the methods in the mode.} + +@language-info-def[definitions-text-surrogate]{ If + @language-info-ref[definitions-text-surrogate] returns + @racket[#f] then DrRacket tries + @racket['definitions-text-surrogate] and expects it to return a value matching the contract - @racket[(or/c #f (non-empty-listof module-path?) module-path?)]. - When given a single @racket[module-path?], it is then passed to + @racket[(or/c #f module-path?)], which is is then passed to @racket[dynamic-require] together with @racket['surrogate%]. The result is expected to be a class implementing the - interface @racket[racket:text-mode<%>] (presumably - derived from @racket[racket:text-mode%]. That mode is - installed into the definitions text, where it can change its - behavior by changing how is responds to any of the methods - in the mode. When given list of @racket[module-path?]s, each element is also - passed to @racket[dynamic-require] with @racket['surrogate%]. The last element - must provide a class as described above. The remaining elements - provide mixins that return a class implementing the @racket[racket:text-mode<%>] - interface. DrRacket traverses this list to generate the surrogate for the - definitions text.} - + interface @racket[racket:text-mode<%>] (presumably derived + from @racket[racket:text-mode%]. That mode is installed into + the definitions text, where it can change its behavior by + changing how is responds to any of the methods in the mode.} One consequence of this power is that errors that happen during the dynamic extent of calls into the mode are not