From 4b57482298c51289c408aee0256b584b08357bf2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 30 Mar 2012 15:54:01 -0500 Subject: [PATCH] adjust DrRacket submodule-running options so the user has more control over which ones get run --- collects/drracket/private/main.rkt | 7 ++ collects/drracket/private/module-language.rkt | 102 ++++++++++++++---- collects/mrlib/scribblings/name-message.scrbl | 6 ++ .../private/english-string-constants.rkt | 4 +- 4 files changed, 96 insertions(+), 23 deletions(-) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 16b18c0be8..bc9bb40f5d 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -11,6 +11,7 @@ racket/path racket/file racket/dict + racket/set browser/external setup/plt-installer) @@ -63,6 +64,12 @@ (application:current-app-name (string-constant drscheme)) +(preferences:set-default 'drracket:submodules-to-choose-from + '((main) (test)) + (cons/c (list/c 'main) + (cons/c (list/c 'test) + (listof (listof symbol?))))) + (drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x))))) (drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution)))) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 88b9688f69..8762e10709 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -19,6 +19,7 @@ setup/dirs racket/place mrlib/close-icon + mrlib/name-message "tooltip.rkt" "drsig.rkt" "rep.rkt" @@ -67,7 +68,7 @@ ;; command-line-args : (vectorof string) ;; auto-text : string (define-struct (module-language-settings drracket:language:simple-settings) - (collection-paths command-line-args auto-text compilation-on? full-trace? run-test-submodule?)) + (collection-paths command-line-args auto-text compilation-on? full-trace? submodules-to-run)) (define (module-language-settings->prefab-module-settings settings) (prefab-module-settings (module-language-settings-command-line-args settings) @@ -78,7 +79,7 @@ (define default-compilation-on? #t) (define default-full-trace? #t) - (define default-run-test-submodule? #t) + (define default-submodules-to-run (list '(main) '(test))) (define (get-default-auto-text) (preferences:get 'drracket:module-language:auto-text)) ;; module-mixin : (implements drracket:language:language<%>) @@ -183,7 +184,7 @@ (get-default-auto-text) default-compilation-on? default-full-trace? - default-run-test-submodule?))) + default-submodules-to-run))) ;; default-settings? : -> boolean (define/override (default-settings? settings) @@ -202,8 +203,8 @@ default-compilation-on?) (equal? (module-language-settings-full-trace? settings) default-full-trace?) - (equal? (module-language-settings-run-test-submodule? settings) - default-run-test-submodule?))) + (equal? (module-language-settings-submodules-to-run settings) + default-submodules-to-run))) (define/override (marshall-settings settings) (let ([super-marshalled (super marshall-settings settings)]) @@ -213,7 +214,7 @@ (module-language-settings-auto-text settings) (module-language-settings-compilation-on? settings) (module-language-settings-full-trace? settings) - (module-language-settings-run-test-submodule? settings)))) + (module-language-settings-submodules-to-run settings)))) (define/override (unmarshall-settings marshalled) (and (list? marshalled) @@ -231,9 +232,9 @@ [full-trace? (if (<= marshalled-len 5) default-full-trace? (list-ref marshalled 5))] - [run-test-submodule? (if (<= marshalled-len 6) - default-run-test-submodule? - (list-ref marshalled 6))]) + [submodules-to-run (if (<= marshalled-len 6) + default-submodules-to-run + (list-ref marshalled 6))]) (and (list? collection-paths) (andmap (λ (x) (or (string? x) (symbol? x))) collection-paths) @@ -241,7 +242,7 @@ (andmap string? (vector->list command-line-args)) (string? auto-text) (boolean? compilation-on?) - (boolean? run-test-submodule?) + ((listof (listof symbol?)) submodules-to-run) (let ([super (super unmarshall-settings (let ([p (car marshalled)]) ;; Convert 'write to 'print: @@ -267,7 +268,7 @@ compilation-on?) full-trace? - run-test-submodule?))))))))))) + submodules-to-run))))))))))) (define/override (on-execute settings run-in-user-thread) (super on-execute settings run-in-user-thread) @@ -385,11 +386,10 @@ (begin (*do-module-specified-configuration) (namespace-require modspec) - (when (module-declared? `(submod ,modspec main) #t) - (dynamic-require `(submod ,modspec main) #f)) - (when (module-language-settings-run-test-submodule? settings) - (when (module-declared? `(submod ,modspec test) #t) - (dynamic-require `(submod ,modspec test) #f)))))))) + (for ([submod (in-list (module-language-settings-submodules-to-run settings))]) + (define submod-spec `(submod ,modspec ,@submod)) + (when (module-declared? submod-spec #t) + (dynamic-require submod-spec #f)))))))) (current-namespace (module->namespace modspec)) (check-interactive-language)) (define (*do-module-specified-configuration) @@ -543,9 +543,20 @@ (define compilation-on-check-box #f) (define compilation-on? #t) (define save-stacktrace-on-check-box #f) - (define run-test-submodule #f) + (define run-submodules-choice #f) (define left-debugging-radio-box #f) (define right-debugging-radio-box #f) + (define submodules-to-run #f) + + (define (sort-submodules-to-run!) + (define ht (make-hash)) + (for ([submod (in-list (preferences:get 'drracket:submodules-to-choose-from))] + [x (in-naturals)]) + (hash-set! ht submod x)) + (set! submodules-to-run (sort submodules-to-run + < + #:key (λ (x) (hash-ref ht x))))) + (define simple-case-lambda (drracket:language:simple-module-based-language-config-panel new-parent @@ -570,9 +581,31 @@ (set! save-stacktrace-on-check-box (new check-box% [label (string-constant preserve-stacktrace-information)] [parent dynamic-panel])) - (set! run-test-submodule (new check-box% - [label (string-constant run-test-submodule)] - [parent dynamic-panel]))))) + (set! run-submodules-choice + (new (class name-message% + (define/override (fill-popup menu reset) + (for ([item (in-list (preferences:get 'drracket:submodules-to-choose-from))] + [x (in-naturals)]) + (new checkable-menu-item% + [label (apply string-append (add-between (map symbol->string item) " "))] + [checked (member item submodules-to-run)] + [callback + (λ (a b) + (if (member item submodules-to-run) + (set! submodules-to-run (remove item submodules-to-run)) + (begin + (set! submodules-to-run (cons item submodules-to-run)) + (sort-submodules-to-run!))))] + [parent menu])) + (new separator-menu-item% [parent menu]) + (new menu-item% + [parent menu] + [callback (λ (a b) (add-another-possible-submodule parent))] + [label (string-constant add-submodule)])) + (super-new + [font normal-control-font] + [parent dynamic-panel] + [label (string-constant submodules-to-run)]))))))) (define (update-compilation-checkbox left-debugging-radio-box right-debugging-radio-box) (case (send left-debugging-radio-box get-selection) [(0 1) @@ -747,7 +780,7 @@ [(0 1) compilation-on?] [(#f) #f]) (send save-stacktrace-on-check-box get-value) - (send run-test-submodule get-value)))))] + submodules-to-run))))] [(settings) (simple-case-lambda settings) (install-collection-paths (module-language-settings-collection-paths settings)) @@ -757,9 +790,34 @@ (send compilation-on-check-box set-value (module-language-settings-compilation-on? settings)) (update-compilation-checkbox left-debugging-radio-box right-debugging-radio-box) (send save-stacktrace-on-check-box set-value (module-language-settings-full-trace? settings)) - (send run-test-submodule set-value (module-language-settings-run-test-submodule? settings)) + (set! submodules-to-run (module-language-settings-submodules-to-run settings)) (update-buttons)])) + (define (add-another-possible-submodule parent) + (define (get-sexp x) + (with-handlers ((exn:fail:read? (λ (x) #f))) + (define p (open-input-string (string-append "(" x ")"))) + (define sexp (read p)) + (and (eof-object? (read-char p)) + (list? sexp) + (andmap symbol? sexp) + sexp))) + (define msg (get-text-from-user (string-constant add-submodule-title) + "submodule" + (let loop ([parent parent]) + (define p (send parent get-parent)) + (if p + (loop p) + parent)) + #:validate (λ (x) (get-sexp x)))) + (define submods + (and msg + (get-sexp msg))) + (when submods + (preferences:set 'drracket:submodules-to-choose-from + (append (preferences:get 'drracket:submodules-to-choose-from) + (list submods))))) + ;; get-filename : port -> (union string #f) ;; extracts the file the definitions window is being saved in, if any. (define (get-filename port) diff --git a/collects/mrlib/scribblings/name-message.scrbl b/collects/mrlib/scribblings/name-message.scrbl index d553311799..524eb73445 100644 --- a/collects/mrlib/scribblings/name-message.scrbl +++ b/collects/mrlib/scribblings/name-message.scrbl @@ -72,6 +72,12 @@ saying that there is no file name until the file is saved.} the @method[name-message% set-message]. } +@defmethod[(fill-popup [menu (is-a?/c popup-menu%)] + [reset (-> void?)])]{ + This method is called when the user clicks in the name message. + Override it to fill in the menu items for the popup menu @racket[menu]. +} + @defmethod[(get-background-color) (or/c #f (is-a/c color%) string?)]{ The result of this method is used for the background color diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 62edfbd2aa..d6d6bc328a 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1095,7 +1095,9 @@ please adhere to these guidelines: (preserve-stacktrace-information "Preserve stacktrace (disable some optimizations)") (expression-level-stacktrace "Expression-level stacktrace") (function-level-stacktrace "Function-level stacktrace") - (run-test-submodule "Run the test submodule") + (submodules-to-run "Submodules to Run") + (add-submodule "Add Submodule Option ...") ;; menu item + (add-submodule-title "Add Submodule") ;; title of dialog opened by above menu item ; used in the bottom left of the drscheme frame