diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index d5e4430879..5308903484 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -567,7 +567,7 @@ (super-new))) ;; create-module-based-language-executable : - ;; (is-a?/c area-container<%>) string module-spec module-spec sexp (union boolean? 'ask) boolean? + ;; (is-a?/c area-container<%>) string (or #f module-spec) module-spec sexp (union boolean? 'ask) boolean? ;; -> void (define (create-module-based-language-executable parent program-filename @@ -890,11 +890,13 @@ (call-with-output-file bootstrap-tmp-filename (λ (port) (write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!) - ,@(if use-copy? - (list - `(namespace-require/copy ',module-language-spec)) - (list - `(namespace-require/constant ',module-language-spec))) + ,@(if module-language-spec + (if use-copy? + (list + `(namespace-require/copy ',module-language-spec)) + (list + `(namespace-require/constant ',module-language-spec))) + '()) ,@(if transformer-module-language-spec (list `(namespace-require `(for-syntax ,transformer-module-language-spec))) (list)) @@ -914,11 +916,16 @@ #:exists 'truncate #:mode 'text))) (let* ([pre-to-be-embedded-module-specs0 - (if (or (not transformer-module-language-spec) - (equal? module-language-spec transformer-module-language-spec)) - (list module-language-spec) - (list module-language-spec - transformer-module-language-spec))] + (cond + [(and module-language-spec transformer-module-language-spec) + (if (equal? module-language-spec transformer-module-language-spec) + (list module-language-spec) + (list module-language-spec transformer-module-language-spec))] + [module-language-spec + (list module-language-spec)] + [transformer-module-language-spec + (list transformer-module-language-spec)] + [else '()])] [pre-to-be-embedded-module-specs1 (if gui? (cons '(lib "mred/mred.ss") @@ -969,7 +976,7 @@ gui? use-copy?)))) - ;; create-module-based-distribution : ... -> void (see docs) + ;; create-distribution-for-executable : ... -> void (see docs) (define (create-distribution-for-executable distribution-filename gui? make-executable) @@ -1116,7 +1123,7 @@ (path->string executable-filename) executable-filename)))) - ;; initialize-module-based-language : boolean module-spec module-spec ((-> void) -> void) + ;; initialize-module-based-language : boolean (or #f module-spec) module-spec ((-> void) -> void) (define (initialize-module-based-language use-copy? module-spec transformer-module-spec @@ -1127,9 +1134,10 @@ (λ (x) (display (exn-message x)) (newline))]) - (if use-copy? - (namespace-require/copy module-spec) - (namespace-require/constant module-spec)) + (when module-spec + (if use-copy? + (namespace-require/copy module-spec) + (namespace-require/constant module-spec))) (when transformer-module-spec (namespace-require `(for-syntax ,transformer-module-spec))))))) diff --git a/collects/drscheme/private/launcher-bootstrap.ss b/collects/drscheme/private/launcher-bootstrap.ss index 908e110175..5dfface500 100644 --- a/collects/drscheme/private/launcher-bootstrap.ss +++ b/collects/drscheme/private/launcher-bootstrap.ss @@ -41,7 +41,8 @@ to-be-copied-module-names) (namespace-set-variable-value! 'argv program-argv) (current-command-line-arguments program-argv) - (namespace-require language-module-spec) + (when language-module-spec + (namespace-require language-module-spec)) (when use-require/copy? (namespace-require/copy language-module-spec)) (when transformer-module-spec diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 83667fcfe6..48a703015b 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -1,566 +1,569 @@ +#lang scheme/base -(module module-language mzscheme - (provide module-language@) - (require mzlib/unit - mzlib/class - mred - compiler/embed - launcher - framework - string-constants - "drsig.ss" - mzlib/contract) +(provide module-language@) +(require scheme/unit + scheme/class + mred + compiler/embed + launcher + framework + string-constants + "drsig.ss" + scheme/contract) + +(define op (current-output-port)) +(define (oprintf . args) (apply fprintf op args)) + +(define-unit module-language@ + (import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] + [prefix drscheme:language: drscheme:language^] + [prefix drscheme:unit: drscheme:unit^] + [prefix drscheme:rep: drscheme:rep^]) + (export drscheme:module-language^) - (define op (current-output-port)) - (define (oprintf . args) (apply fprintf op args)) + (define module-language<%> + (interface () + )) - (define-unit module-language@ - (import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] - [prefix drscheme:language: drscheme:language^] - [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:rep: drscheme:rep^]) - (export drscheme:module-language^) - - (define module-language<%> - (interface () - )) - - ;; add-module-language : -> void - ;; adds the special module-only language to drscheme - (define (add-module-language) - (define module-language% - (module-mixin - ((drscheme:language:get-default-mixin) - (drscheme:language:module-based-language->language-mixin - (drscheme:language:simple-module-based-language->module-based-language-mixin - drscheme:language:simple-module-based-language%))))) - (drscheme:language-configuration:add-language - (instantiate module-language% ()))) - - ;; collection-paths : (listof (union 'default string)) - ;; command-line-args : (vectorof string) - (define-struct (module-language-settings drscheme:language:simple-settings) - (collection-paths command-line-args)) - - ;; module-mixin : (implements drscheme:language:language<%>) - ;; -> (implements drscheme:language:language<%>) - (define (module-mixin %) - (class* % (drscheme:language:language<%> module-language<%>) - (define/override (use-namespace-require/copy?) #t) - (field [iteration-number 0]) - - (define/augment (capability-value key) - (cond - [(eq? key 'drscheme:autocomplete-words) - (drscheme:language-configuration:get-all-scheme-manual-keywords)] - [else (drscheme:language:get-capability-default key)])) - - ;; config-panel : as in super class - ;; uses drscheme:language:simple-module-based-language-config-panel - ;; and adds a collection paths configuration to it. - (define/override (config-panel parent) - (module-language-config-panel parent)) - - (define/override (default-settings) - (let ([super-defaults (super default-settings)]) - (apply make-module-language-settings - (append - (vector->list (drscheme:language:simple-settings->vector super-defaults)) - (list '(default) - #()))))) - - ;; default-settings? : -> boolean - (define/override (default-settings? settings) - (and (super default-settings? settings) - (equal? (module-language-settings-collection-paths settings) - '(default)) - (equal? (module-language-settings-command-line-args settings) - #()))) - - (define/override (marshall-settings settings) - (let ([super-marshalled (super marshall-settings settings)]) - (list super-marshalled - (module-language-settings-collection-paths settings) - (module-language-settings-command-line-args settings)))) - - (define/override (unmarshall-settings marshalled) - (and (pair? marshalled) - (pair? (cdr marshalled)) - (pair? (cddr marshalled)) - (null? (cdddr marshalled)) - (list? (cadr marshalled)) - (vector? (caddr marshalled)) - (andmap string? (vector->list (caddr marshalled))) - (andmap (λ (x) (or (string? x) (symbol? x))) - (cadr marshalled)) - (let ([super (super unmarshall-settings (car marshalled))]) - (and super - (apply make-module-language-settings - (append - (vector->list (drscheme:language:simple-settings->vector super)) - (list (cadr marshalled) - (caddr marshalled)))))))) - - (define/override (on-execute settings run-in-user-thread) - (set! iteration-number 0) - (super on-execute settings run-in-user-thread) - (run-in-user-thread - (λ () - (current-command-line-arguments (module-language-settings-command-line-args settings)) - (let ([default (current-library-collection-paths)]) - (current-library-collection-paths - (apply - append - (map (λ (x) (if (symbol? x) - default - (list x))) - (module-language-settings-collection-paths settings)))))))) - - (define/override (get-one-line-summary) - (string-constant module-language-one-line-summary)) - - (inherit get-reader) - (define/override (front-end/complete-program port settings) - (let* ([super-thunk (λ () ((get-reader) (object-name port) port))] - [path (get-filename port)] - [module-name #f] - [module-name-prefix (get-module-name-prefix path)] - - [get-require-module-name - (λ () - ;; "clearing out" the module-name via datum->syntax-object ensures - ;; that check syntax doesn't think the original module name - ;; is being used in this require (so it doesn't get turned red) - (datum->syntax-object #'here (syntax-e module-name)))]) - (λ () - (set! iteration-number (+ iteration-number 1)) - (cond - [(= 1 iteration-number) - #`(current-module-declare-name - (if #,path - (make-resolved-module-path '#,path) - #f))] - [(= 2 iteration-number) - (let ([super-result (super-thunk)]) - (if (eof-object? super-result) - (raise-syntax-error - 'module-language - "the definitions window must contain a module") - (let-values ([(name new-module) - (transform-module path super-result)]) - (set! module-name name) - new-module)))] - [(= 3 iteration-number) - (let ([super-result (super-thunk)]) - (if (eof-object? super-result) - #`(begin - (current-module-declare-name #f) - #,(if path - #`(begin - ((current-module-name-resolver) (make-resolved-module-path #,path)) - (call-with-continuation-prompt - (λ () (dynamic-require #,path #f)))) - #`(call-with-continuation-prompt - (λ () (dynamic-require ''#,(get-require-module-name) #f))))) - (raise-syntax-error - 'module-language - "there can only be one expression in the definitions window" - super-result)))] - [(= 4 iteration-number) - (if path - #`(#%app current-namespace - (#%app - module->namespace - #,path)) - #`(#%app current-namespace - (#%app - module->namespace - ''#,(get-require-module-name))))] - [else eof])))) - - ;; printer settings are just ignored here. - (define/override (create-executable setting parent program-filename) - (let* ([executable-specs (drscheme:language:create-executable-gui - parent - program-filename - #t - #t)]) - (when executable-specs - (let ([launcher? (eq? 'launcher (car executable-specs))] - [gui? (eq? 'mred (cadr executable-specs))] - [executable-filename (caddr executable-specs)]) - (with-handlers ([(λ (x) #f) ;exn:fail? - (λ (x) - (message-box - (string-constant drscheme) - (if (exn? x) - (format "~a" (exn-message x)) - (format "uncaught exception: ~s" x))))]) - (if (not launcher?) - (let ([short-program-name - (let-values ([(base name dir) (split-path program-filename)]) - (path-replace-suffix name #""))]) - ((if (eq? 'distribution (car executable-specs)) - drscheme:language:create-distribution-for-executable - (lambda (executable-filename gui? make) - (make executable-filename))) - executable-filename - gui? - (lambda (exe-name) - (make-embedding-executable - exe-name - gui? - #f ;; verbose? - (list (list #f program-filename)) - null - (parameterize ([current-namespace (make-namespace 'empty)]) - (namespace-require 'mzscheme) - (compile - `(namespace-require '',(string->symbol (path->string short-program-name))))) - null)))) - (let ([make-launcher (if gui? make-mred-launcher make-mzscheme-launcher)]) - (make-launcher (list "-qt-" (path->string program-filename)) - executable-filename)))))))) - - (super-new - (module 'scheme/base) - (language-position (list "Module")) - (language-numbers (list -32768))))) - - ;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void)) - (define (module-language-config-panel parent) - (define new-parent - (instantiate vertical-panel% () - (parent parent) - (alignment '(center center)) - (stretchable-height #f) - (stretchable-width #f))) - (define simple-case-lambda (drscheme:language:simple-module-based-language-config-panel new-parent)) - (define cp-panel (instantiate group-box-panel% () - (parent new-parent) - (label (string-constant ml-cp-collection-paths)))) + ;; add-module-language : -> void + ;; adds the special module-only language to drscheme + (define (add-module-language) + (define module-language% + (module-mixin + ((drscheme:language:get-default-mixin) + (drscheme:language:module-based-language->language-mixin + (drscheme:language:simple-module-based-language->module-based-language-mixin + drscheme:language:simple-module-based-language%))))) + (drscheme:language-configuration:add-language + (instantiate module-language% ()))) + + ;; collection-paths : (listof (union 'default string)) + ;; command-line-args : (vectorof string) + (define-struct (module-language-settings drscheme:language:simple-settings) + (collection-paths command-line-args)) + + ;; module-mixin : (implements drscheme:language:language<%>) + ;; -> (implements drscheme:language:language<%>) + (define (module-mixin %) + (class* % (drscheme:language:language<%> module-language<%>) + (define/override (use-namespace-require/copy?) #t) + (field [iteration-number 0]) - (define args-panel (instantiate group-box-panel% () - (parent new-parent) - (label (string-constant ml-command-line-arguments)))) - (define args-text-box (new text-field% - (parent args-panel) - (label #f) - (init-value "#()") - (callback void))) - - ;; data associated with each item in listbox : boolean - ;; indicates if the entry is the default paths. - (define lb (instantiate list-box% () - (parent cp-panel) - (choices '("a" "b" "c")) - (label #f) - (callback (λ (x y) (update-buttons))))) - (define button-panel (instantiate horizontal-panel% () - (parent cp-panel) - (alignment '(center center)) - (stretchable-height #f))) - (define add-button (make-object button% (string-constant ml-cp-add) button-panel - (λ (x y) (add-callback)))) - (define add-default-button (make-object button% (string-constant ml-cp-add-default) button-panel - (λ (x y) (add-default-callback)))) - (define remove-button (make-object button% (string-constant ml-cp-remove) button-panel - (λ (x y) (remove-callback)))) - (define raise-button (make-object button% (string-constant ml-cp-raise) button-panel - (λ (x y) (raise-callback)))) - (define lower-button (make-object button% (string-constant ml-cp-lower) button-panel - (λ (x y) (lower-callback)))) - - (define (update-buttons) - (let ([lb-selection (send lb get-selection)] - [lb-tot (send lb get-number)]) - (send remove-button enable lb-selection) - (send raise-button enable - (and lb-selection - (not (= lb-selection 0)))) - (send lower-button enable - (and lb-selection - (not (= lb-selection (- lb-tot 1))))))) - - (define (add-callback) - (let ([dir (get-directory - (string-constant ml-cp-choose-a-collection-path) - (send parent get-top-level-window))]) - (when dir - (send lb append (path->string dir) #f) - (update-buttons)))) - - (define (add-default-callback) + (define/augment (capability-value key) (cond - [(has-default?) - (message-box (string-constant drscheme) - (string-constant ml-cp-default-already-present) - (send parent get-top-level-window))] - [else - (send lb append (string-constant ml-cp-default-collection-path) #t) - (update-buttons)])) + [(eq? key 'drscheme:autocomplete-words) + (drscheme:language-configuration:get-all-scheme-manual-keywords)] + [else (drscheme:language:get-capability-default key)])) - ;; has-default? : -> boolean - ;; returns #t if the `default' entry has already been added - (define (has-default?) - (let loop ([n (send lb get-number)]) - (cond - [(= n 0) #f] - [(send lb get-data (- n 1)) #t] - [else (loop (- n 1))]))) + ;; config-panel : as in super class + ;; uses drscheme:language:simple-module-based-language-config-panel + ;; and adds a collection paths configuration to it. + (define/override (config-panel parent) + (module-language-config-panel parent)) - (define (remove-callback) - (let ([to-delete (send lb get-selection)]) - (send lb delete to-delete) - (unless (zero? (send lb get-number)) - (send lb set-selection (min to-delete - (- (send lb get-number) 1)))) - (update-buttons))) + (define/override (default-settings) + (let ([super-defaults (super default-settings)]) + (apply make-module-language-settings + (append + (vector->list (drscheme:language:simple-settings->vector super-defaults)) + (list '(default) + #()))))) - (define (lower-callback) - (let* ([sel (send lb get-selection)] - [vec (get-lb-vector)] - [below (vector-ref vec (+ sel 1))]) - (vector-set! vec (+ sel 1) (vector-ref vec sel)) - (vector-set! vec sel below) - (set-lb-vector vec) - (send lb set-selection (+ sel 1)) - (update-buttons))) + ;; default-settings? : -> boolean + (define/override (default-settings? settings) + (and (super default-settings? settings) + (equal? (module-language-settings-collection-paths settings) + '(default)) + (equal? (module-language-settings-command-line-args settings) + #()))) - (define (raise-callback) - (let* ([sel (send lb get-selection)] - [vec (get-lb-vector)] - [above (vector-ref vec (- sel 1))]) - (vector-set! vec (- sel 1) (vector-ref vec sel)) - (vector-set! vec sel above) - (set-lb-vector vec) - (send lb set-selection (- sel 1)) - (update-buttons))) + (define/override (marshall-settings settings) + (let ([super-marshalled (super marshall-settings settings)]) + (list super-marshalled + (module-language-settings-collection-paths settings) + (module-language-settings-command-line-args settings)))) - (define (get-lb-vector) - (list->vector - (let loop ([n 0]) - (cond - [(= n (send lb get-number)) null] - [else (cons (cons (send lb get-string n) - (send lb get-data n)) - (loop (+ n 1)))])))) + (define/override (unmarshall-settings marshalled) + (and (pair? marshalled) + (pair? (cdr marshalled)) + (pair? (cddr marshalled)) + (null? (cdddr marshalled)) + (list? (cadr marshalled)) + (vector? (caddr marshalled)) + (andmap string? (vector->list (caddr marshalled))) + (andmap (λ (x) (or (string? x) (symbol? x))) + (cadr marshalled)) + (let ([super (super unmarshall-settings (car marshalled))]) + (and super + (apply make-module-language-settings + (append + (vector->list (drscheme:language:simple-settings->vector super)) + (list (cadr marshalled) + (caddr marshalled)))))))) - (define (set-lb-vector vec) - (send lb clear) - (let loop ([n 0]) - (cond - [(= n (vector-length vec)) (void)] - [else (send lb append (car (vector-ref vec n))) - (send lb set-data n (cdr (vector-ref vec n))) - (loop (+ n 1))]))) + (define/override (on-execute settings run-in-user-thread) + (set! iteration-number 0) + (super on-execute settings run-in-user-thread) + (run-in-user-thread + (λ () + (current-command-line-arguments (module-language-settings-command-line-args settings)) + (let ([default (current-library-collection-paths)]) + (current-library-collection-paths + (apply + append + (map (λ (x) (if (symbol? x) + default + (list x))) + (module-language-settings-collection-paths settings)))))))) - (define (get-collection-paths) - (let loop ([n 0]) - (cond - [(= n (send lb get-number)) null] - [else - (let ([data (send lb get-data n)]) - (cons (if data - 'default - (send lb get-string n)) - (loop (+ n 1))))]))) + (define/override (get-one-line-summary) + (string-constant module-language-one-line-summary)) - (define (install-collection-paths paths) - (send lb clear) - (for-each (λ (cp) - (if (symbol? cp) - (send lb append - (string-constant ml-cp-default-collection-path) - #t) - (send lb append cp #f))) - paths)) - - (define (get-command-line-args) - (let ([str (send args-text-box get-value)]) - (let ([read-res (parameterize ([read-accept-graph #f]) - (with-handlers ([exn:fail:read? (λ (x) #())]) - (read (open-input-string str))))]) + (inherit get-reader) + (define/override (front-end/complete-program port settings) + (let* ([super-thunk (λ () ((get-reader) (object-name port) port))] + [path (get-filename port)] + [module-name #f] + [module-name-prefix (get-module-name-prefix path)] + + [get-require-module-name + (λ () + ;; "clearing out" the module-name via datum->syntax ensures + ;; that check syntax doesn't think the original module name + ;; is being used in this require (so it doesn't get turned red) + (datum->syntax #'here (syntax-e module-name)))]) + (λ () + (set! iteration-number (+ iteration-number 1)) (cond - [(and (vector? read-res) - (andmap string? (vector->list read-res))) - read-res] - [else #()])))) + [(= 1 iteration-number) + #`(current-module-declare-name + (if #,path + (make-resolved-module-path '#,path) + #f))] + [(= 2 iteration-number) + (let ([super-result (super-thunk)]) + (if (eof-object? super-result) + (raise-syntax-error + 'module-language + "the definitions window must contain a module") + (let-values ([(name new-module) + (transform-module path super-result)]) + (set! module-name name) + new-module)))] + [(= 3 iteration-number) + (let ([super-result (super-thunk)]) + (if (eof-object? super-result) + #`(begin + (current-module-declare-name #f) + #,(if path + #`(begin + ((current-module-name-resolver) (make-resolved-module-path #,path)) + (call-with-continuation-prompt + (λ () (dynamic-require #,path #f)))) + #`(call-with-continuation-prompt + (λ () (dynamic-require ''#,(get-require-module-name) #f))))) + (raise-syntax-error + 'module-language + "there can only be one expression in the definitions window" + super-result)))] + [(= 4 iteration-number) + (if path + #`(#%app current-namespace + (#%app + module->namespace + #,path)) + #`(#%app current-namespace + (#%app + module->namespace + ''#,(get-require-module-name))))] + [else eof])))) - (define (install-command-line-args vec) - (send args-text-box set-value - (parameterize ([print-vector-length #f]) - (format "~s" vec)))) + ;; printer settings are just ignored here. + (define/override (create-executable setting parent program-filename) + (let* ([executable-specs (drscheme:language:create-executable-gui + parent + program-filename + #t + #t)]) + (when executable-specs + (let ([launcher? (eq? 'launcher (car executable-specs))] + [gui? (eq? 'mred (cadr executable-specs))] + [executable-filename (caddr executable-specs)]) + (with-handlers ([(λ (x) #f) ;exn:fail? + (λ (x) + (message-box + (string-constant drscheme) + (if (exn? x) + (format "~a" (exn-message x)) + (format "uncaught exception: ~s" x))))]) + (if (not launcher?) + (let ([short-program-name + (let-values ([(base name dir) (split-path program-filename)]) + (path-replace-suffix name #""))]) + ((if (eq? 'distribution (car executable-specs)) + drscheme:language:create-distribution-for-executable + (lambda (executable-filename gui? make) + (make executable-filename))) + executable-filename + gui? + (lambda (exe-name) + (make-embedding-executable + exe-name + gui? + #f ;; verbose? + (list (list #f program-filename)) + null + (parameterize ([current-namespace (make-empty-namespace)]) + (namespace-require 'mzscheme) + (compile + `(namespace-require '',(string->symbol (path->string short-program-name))))) + null)))) + (let ([make-launcher (if gui? make-mred-launcher make-mzscheme-launcher)]) + (make-launcher (list "-qt-" (path->string program-filename)) + executable-filename)))))))) - (send lb set '()) - (update-buttons) - - (case-lambda - [() - (let ([simple-settings (simple-case-lambda)]) - (apply make-module-language-settings - (append - (vector->list (drscheme:language:simple-settings->vector simple-settings)) - (list (get-collection-paths) - (get-command-line-args)))))] - [(settings) - (simple-case-lambda settings) - (install-collection-paths (module-language-settings-collection-paths settings)) - (install-command-line-args (module-language-settings-command-line-args settings)) + (super-new + (module #f) + (language-position (list "Module")) + (language-numbers (list -32768))))) + + ;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void)) + (define (module-language-config-panel parent) + (define new-parent + (instantiate vertical-panel% () + (parent parent) + (alignment '(center center)) + (stretchable-height #f) + (stretchable-width #f))) + (define simple-case-lambda (drscheme:language:simple-module-based-language-config-panel new-parent)) + (define cp-panel (instantiate group-box-panel% () + (parent new-parent) + (label (string-constant ml-cp-collection-paths)))) + + (define args-panel (instantiate group-box-panel% () + (parent new-parent) + (label (string-constant ml-command-line-arguments)))) + (define args-text-box (new text-field% + (parent args-panel) + (label #f) + (init-value "#()") + (callback void))) + + ;; data associated with each item in listbox : boolean + ;; indicates if the entry is the default paths. + (define lb (instantiate list-box% () + (parent cp-panel) + (choices '("a" "b" "c")) + (label #f) + (callback (λ (x y) (update-buttons))))) + (define button-panel (instantiate horizontal-panel% () + (parent cp-panel) + (alignment '(center center)) + (stretchable-height #f))) + (define add-button (make-object button% (string-constant ml-cp-add) button-panel + (λ (x y) (add-callback)))) + (define add-default-button (make-object button% (string-constant ml-cp-add-default) button-panel + (λ (x y) (add-default-callback)))) + (define remove-button (make-object button% (string-constant ml-cp-remove) button-panel + (λ (x y) (remove-callback)))) + (define raise-button (make-object button% (string-constant ml-cp-raise) button-panel + (λ (x y) (raise-callback)))) + (define lower-button (make-object button% (string-constant ml-cp-lower) button-panel + (λ (x y) (lower-callback)))) + + (define (update-buttons) + (let ([lb-selection (send lb get-selection)] + [lb-tot (send lb get-number)]) + (send remove-button enable lb-selection) + (send raise-button enable + (and lb-selection + (not (= lb-selection 0)))) + (send lower-button enable + (and lb-selection + (not (= lb-selection (- lb-tot 1))))))) + + (define (add-callback) + (let ([dir (get-directory + (string-constant ml-cp-choose-a-collection-path) + (send parent get-top-level-window))]) + (when dir + (send lb append (path->string dir) #f) + (update-buttons)))) + + (define (add-default-callback) + (cond + [(has-default?) + (message-box (string-constant drscheme) + (string-constant ml-cp-default-already-present) + (send parent get-top-level-window))] + [else + (send lb append (string-constant ml-cp-default-collection-path) #t) (update-buttons)])) - ;; transform-module : (union #f string) syntax syntax -> (values symbol[name-of-module] syntax[module]) - ;; in addition to exporting everything, the result module's name - ;; is the fully path-expanded name with a directory prefix, - ;; if the file has been saved - (define (transform-module filename stx) - (syntax-case stx (module) - [(module name lang bodies ...) - (let ([v-name (syntax name)]) - (when filename - (check-filename-matches filename - (syntax-object->datum (syntax name)) - stx)) - (values v-name stx))] - [else - (raise-syntax-error 'module-language - "only module expressions are allowed" - stx)])) - - ;; get-module-name-prefix : path -> string - ;; returns the symbol that gets passed the current-module-name-prefix - ;; while evaluating/expanding the module. - (define (get-module-name-prefix path) - (and path - (let-values ([(base name dir) - (split-path (normal-case-path (simplify-path (expand-path path) #f)))]) - (string->symbol (format ",~a" (bytes->string/latin-1 (path->bytes base))))))) - - ;; build-name : path -> symbol - (define (build-name pre-path) - (let ([path (normal-case-path (simplify-path (expand-path pre-path) #f))]) - (let-values ([(base name dir) (split-path path)]) - (string->symbol (format ",~a" - (bytes->string/latin-1 - (path->bytes - (build-path - base - (remove-suffix (path->string name)))))))))) - - ;; get-filename : port -> (union string #f) - ;; extracts the file the definitions window is being saved in, if any. - (define (get-filename port) - (let ([source (object-name port)]) + ;; has-default? : -> boolean + ;; returns #t if the `default' entry has already been added + (define (has-default?) + (let loop ([n (send lb get-number)]) (cond - [(path? source) source] - [(is-a? source text%) - (let ([canvas (send source get-canvas)]) - (and canvas - (let ([frame (send canvas get-top-level-window)]) - (and (is-a? frame drscheme:unit:frame%) - (let* ([b (box #f)] - [filename (send (send frame get-definitions-text) - get-filename - b)]) - (if (unbox b) - #f - filename))))))] - [else #f]))) + [(= n 0) #f] + [(send lb get-data (- n 1)) #t] + [else (loop (- n 1))]))) - ;; check-filename-matches : string datum syntax -> void - (define (check-filename-matches filename datum unexpanded-stx) - (unless (symbol? datum) - (raise-syntax-error 'module-language "unexpected object in name position of module" - unexpanded-stx)) - (let-values ([(base name dir?) (split-path filename)]) - (let* ([expected (string->symbol (remove-suffix (path->string name)))]) - (unless (equal? expected datum) - (raise-syntax-error - 'module-language - (format "module name doesn't match saved filename, got ~s and expected ~a" - datum - expected) - unexpanded-stx))))) + (define (remove-callback) + (let ([to-delete (send lb get-selection)]) + (send lb delete to-delete) + (unless (zero? (send lb get-number)) + (send lb set-selection (min to-delete + (- (send lb get-number) 1)))) + (update-buttons))) - (define re:check-filename-matches #rx"^(.*)\\.[^.]*$") - (define (remove-suffix str) - (let ([m (regexp-match re:check-filename-matches str)]) - (if m - (cadr m) - str))) + (define (lower-callback) + (let* ([sel (send lb get-selection)] + [vec (get-lb-vector)] + [below (vector-ref vec (+ sel 1))]) + (vector-set! vec (+ sel 1) (vector-ref vec sel)) + (vector-set! vec sel below) + (set-lb-vector vec) + (send lb set-selection (+ sel 1)) + (update-buttons))) + (define (raise-callback) + (let* ([sel (send lb get-selection)] + [vec (get-lb-vector)] + [above (vector-ref vec (- sel 1))]) + (vector-set! vec (- sel 1) (vector-ref vec sel)) + (vector-set! vec sel above) + (set-lb-vector vec) + (send lb set-selection (- sel 1)) + (update-buttons))) - (define module-language-put-file-mixin - (mixin (text:basic<%>) () - (inherit get-text last-position get-character get-top-level-window) - (define/override (put-file directory default-name) - (let ([tlw (get-top-level-window)]) - (if (and tlw - (is-a? tlw drscheme:unit:frame<%>)) - (let* ([definitions-text (send tlw get-definitions-text)] - [module-language? - (is-a? (drscheme:language-configuration:language-settings-language - (send definitions-text get-next-settings)) - module-language<%>)] - [module-default-filename - (and module-language? (get-module-filename))]) - (super put-file directory module-default-filename)) - (super put-file directory default-name)))) - - ;; returns the name after "(module " suffixed with .scm - ;; in the beginning of the editor - ;; or #f if the beginning doesn't match "(module " - (define/private (get-module-filename) - (let ([open-paren (skip-whitespace 0)]) - (or (match-paren open-paren "(") - (match-paren open-paren "[") - (match-paren open-paren "{")))) - - (define/private (match-paren open-paren paren) - (and (matches open-paren paren) - (let ([module (skip-whitespace (+ open-paren 1))]) - (and (matches module "module") - (let* ([end-module (+ module (string-length "module"))] - [filename-start (skip-whitespace end-module)] - [filename-end (skip-to-whitespace filename-start)]) - (and (not (= filename-start end-module)) - (string-append (get-text filename-start filename-end) - ".scm"))))))) - - - (define/private (matches start string) - (let ([last-pos (last-position)]) - (let loop ([i 0]) - (cond - [(and (i . < . (string-length string)) - ((+ i start) . < . last-pos)) - (and (char=? (string-ref string i) - (get-character (+ i start))) - (loop (+ i 1)))] - [(= i (string-length string)) #t] - [else #f])))) - - (define/private (skip-whitespace start) - (let ([last-pos (last-position)]) - (let loop ([pos start]) - (cond - [(pos . >= . last-pos) last-pos] - [else - (let ([char (get-character pos)]) - (cond - [(char-whitespace? char) - (loop (+ pos 1))] - [else pos]))])))) - - (define/private (skip-to-whitespace start) - (let ([last-pos (last-position)]) - (let loop ([pos start]) - (cond - [(pos . >= . last-pos) - last-pos] - [(char-whitespace? (get-character pos)) - pos] - [else - (loop (+ pos 1))])))) - - (super-new))))) + (define (get-lb-vector) + (list->vector + (let loop ([n 0]) + (cond + [(= n (send lb get-number)) null] + [else (cons (cons (send lb get-string n) + (send lb get-data n)) + (loop (+ n 1)))])))) + + (define (set-lb-vector vec) + (send lb clear) + (let loop ([n 0]) + (cond + [(= n (vector-length vec)) (void)] + [else (send lb append (car (vector-ref vec n))) + (send lb set-data n (cdr (vector-ref vec n))) + (loop (+ n 1))]))) + + (define (get-collection-paths) + (let loop ([n 0]) + (cond + [(= n (send lb get-number)) null] + [else + (let ([data (send lb get-data n)]) + (cons (if data + 'default + (send lb get-string n)) + (loop (+ n 1))))]))) + + (define (install-collection-paths paths) + (send lb clear) + (for-each (λ (cp) + (if (symbol? cp) + (send lb append + (string-constant ml-cp-default-collection-path) + #t) + (send lb append cp #f))) + paths)) + + (define (get-command-line-args) + (let ([str (send args-text-box get-value)]) + (let ([read-res (parameterize ([read-accept-graph #f]) + (with-handlers ([exn:fail:read? (λ (x) #())]) + (read (open-input-string str))))]) + (cond + [(and (vector? read-res) + (andmap string? (vector->list read-res))) + read-res] + [else #()])))) + + (define (install-command-line-args vec) + (send args-text-box set-value + (parameterize ([print-vector-length #f]) + (format "~s" vec)))) + + (send lb set '()) + (update-buttons) + + (case-lambda + [() + (let ([simple-settings (simple-case-lambda)]) + (apply make-module-language-settings + (append + (vector->list (drscheme:language:simple-settings->vector simple-settings)) + (list (get-collection-paths) + (get-command-line-args)))))] + [(settings) + (simple-case-lambda settings) + (install-collection-paths (module-language-settings-collection-paths settings)) + (install-command-line-args (module-language-settings-command-line-args settings)) + (update-buttons)])) + + ;; transform-module : (union #f string) syntax syntax -> (values symbol[name-of-module] syntax[module]) + ;; in addition to exporting everything, the result module's name + ;; is the fully path-expanded name with a directory prefix, + ;; if the file has been saved + (define (transform-module filename stx) + (syntax-case* stx (module) (λ (x y) (eq? (syntax-e x) (syntax-e y))) + [(module name lang bodies ...) + (let ([v-name (syntax name)]) + (when filename + (check-filename-matches filename + (syntax->datum (syntax name)) + stx)) + ;; rewrite the module to use the scheme/base version of `module' + (values v-name + #`(#,(datum->syntax #'here 'module) + name lang bodies ...)))] + [else + (raise-syntax-error 'module-language + "only module expressions are allowed" + stx)])) + + ;; get-module-name-prefix : path -> string + ;; returns the symbol that gets passed the current-module-name-prefix + ;; while evaluating/expanding the module. + (define (get-module-name-prefix path) + (and path + (let-values ([(base name dir) + (split-path (normal-case-path (simplify-path (expand-user-path path) #f)))]) + (string->symbol (format ",~a" (bytes->string/latin-1 (path->bytes base))))))) + + ;; build-name : path -> symbol + (define (build-name pre-path) + (let ([path (normal-case-path (simplify-path (expand-user-path pre-path) #f))]) + (let-values ([(base name dir) (split-path path)]) + (string->symbol (format ",~a" + (bytes->string/latin-1 + (path->bytes + (build-path + base + (remove-suffix (path->string name)))))))))) + + ;; get-filename : port -> (union string #f) + ;; extracts the file the definitions window is being saved in, if any. + (define (get-filename port) + (let ([source (object-name port)]) + (cond + [(path? source) source] + [(is-a? source text%) + (let ([canvas (send source get-canvas)]) + (and canvas + (let ([frame (send canvas get-top-level-window)]) + (and (is-a? frame drscheme:unit:frame%) + (let* ([b (box #f)] + [filename (send (send frame get-definitions-text) + get-filename + b)]) + (if (unbox b) + #f + filename))))))] + [else #f]))) + + ;; check-filename-matches : string datum syntax -> void + (define (check-filename-matches filename datum unexpanded-stx) + (unless (symbol? datum) + (raise-syntax-error 'module-language "unexpected object in name position of module" + unexpanded-stx)) + (let-values ([(base name dir?) (split-path filename)]) + (let* ([expected (string->symbol (remove-suffix (path->string name)))]) + (unless (equal? expected datum) + (raise-syntax-error + 'module-language + (format "module name doesn't match saved filename, got ~s and expected ~a" + datum + expected) + unexpanded-stx))))) + + (define re:check-filename-matches #rx"^(.*)\\.[^.]*$") + (define (remove-suffix str) + (let ([m (regexp-match re:check-filename-matches str)]) + (if m + (cadr m) + str))) + + + (define module-language-put-file-mixin + (mixin (text:basic<%>) () + (inherit get-text last-position get-character get-top-level-window) + (define/override (put-file directory default-name) + (let ([tlw (get-top-level-window)]) + (if (and tlw + (is-a? tlw drscheme:unit:frame<%>)) + (let* ([definitions-text (send tlw get-definitions-text)] + [module-language? + (is-a? (drscheme:language-configuration:language-settings-language + (send definitions-text get-next-settings)) + module-language<%>)] + [module-default-filename + (and module-language? (get-module-filename))]) + (super put-file directory module-default-filename)) + (super put-file directory default-name)))) + + ;; returns the name after "(module " suffixed with .scm + ;; in the beginning of the editor + ;; or #f if the beginning doesn't match "(module " + (define/private (get-module-filename) + (let ([open-paren (skip-whitespace 0)]) + (or (match-paren open-paren "(") + (match-paren open-paren "[") + (match-paren open-paren "{")))) + + (define/private (match-paren open-paren paren) + (and (matches open-paren paren) + (let ([module (skip-whitespace (+ open-paren 1))]) + (and (matches module "module") + (let* ([end-module (+ module (string-length "module"))] + [filename-start (skip-whitespace end-module)] + [filename-end (skip-to-whitespace filename-start)]) + (and (not (= filename-start end-module)) + (string-append (get-text filename-start filename-end) + ".scm"))))))) + + + (define/private (matches start string) + (let ([last-pos (last-position)]) + (let loop ([i 0]) + (cond + [(and (i . < . (string-length string)) + ((+ i start) . < . last-pos)) + (and (char=? (string-ref string i) + (get-character (+ i start))) + (loop (+ i 1)))] + [(= i (string-length string)) #t] + [else #f])))) + + (define/private (skip-whitespace start) + (let ([last-pos (last-position)]) + (let loop ([pos start]) + (cond + [(pos . >= . last-pos) last-pos] + [else + (let ([char (get-character pos)]) + (cond + [(char-whitespace? char) + (loop (+ pos 1))] + [else pos]))])))) + + (define/private (skip-to-whitespace start) + (let ([last-pos (last-position)]) + (let loop ([pos start]) + (cond + [(pos . >= . last-pos) + last-pos] + [(char-whitespace? (get-character pos)) + pos] + [else + (loop (+ pos 1))])))) + + (super-new)))) diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 6f4f5f8744..20e3f35e0f 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -1198,7 +1198,8 @@ all of the names in the tools library, for use defining keybindings @scheme[module-language-spec] and @scheme[transformer-module-language-spec] specify the settings of the initial namespace, both the transformer - portion and the regular portion. + portion and the regular portion. Both may be @scheme[#f] + to indicate there are no initial bindings. The @scheme[init-code] argument is an s-expression representing the code for a module. This module is expected to provide diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss index fac934a113..b3e15e793d 100644 --- a/collects/tests/drscheme/module-lang-test.ss +++ b/collects/tests/drscheme/module-lang-test.ss @@ -120,6 +120,11 @@ "x" "2") + (make-test + "#lang scheme\n(eval 'cons)" + #f + ". compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: cons") + (make-test (format "~s" `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss"))) 1 2 3)) "1" ;; just make sure no errors.