#lang racket/base (provide module-language@) (require racket/unit racket/class racket/list racket/path racket/contract racket/sandbox mred compiler/embed compiler/cm launcher framework string-constants planet/config setup/dirs "drsig.rkt" "rep.rkt") (define op (current-output-port)) (define (oprintf . args) (apply fprintf op args)) (define-unit module-language@ (import [prefix drracket:language-configuration: drracket:language-configuration/internal^] [prefix drracket:language: drracket:language^] [prefix drracket:unit: drracket:unit^] [prefix drracket:rep: drracket:rep^] [prefix drracket:init: drracket:init^]) (export drracket:module-language^) (define module-language<%> (interface () get-users-language-name get-language-info)) ;; add-module-language : -> void ;; adds the special module-only language to drscheme (define (add-module-language) (define module-language% (module-mixin ((drracket:language:get-default-mixin) (drracket:language:module-based-language->language-mixin (drracket:language:simple-module-based-language->module-based-language-mixin drracket:language:simple-module-based-language%))))) (drracket:language-configuration:add-language (new module-language%))) ;; collection-paths : (listof (union 'default string)) ;; 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?)) (define default-compilation-on? #t) (define default-full-trace? #t) (define default-auto-text "#lang racket\n") ;; module-mixin : (implements drracket:language:language<%>) ;; -> (implements drracket:language:language<%>) (define (module-mixin %) (class* % (drracket:language:language<%> module-language<%>) (define language-info #f) ;; a result from module-compiled-language-info (define sandbox #f) ;; a sandbox for querying the language-info (define/public (get-language-info key default) (init-sandbox) (cond [(and language-info sandbox) (let ([mp (vector-ref language-info 0)] [name (vector-ref language-info 1)] [val (vector-ref language-info 2)]) (call-in-sandbox-context sandbox (λ () (parameterize ([current-security-guard drracket:init:system-security-guard]) (((dynamic-require mp name) val) key default)))))] [else default])) (define (init-sandbox) (unless sandbox (when language-info (set! sandbox (make-evaluator 'racket/base))))) (define/override (first-opened settings) (define ns (get-ns (get-auto-text settings))) (when ns (current-namespace ns))) (define/private (get-ns str) (define ev (make-evaluator 'racket/base)) (ev `(parameterize ([read-accept-reader #t]) (define stx (read-syntax "here" (open-input-string ,str))) (define modname (syntax-case stx () [(module name . stuff) `',(syntax->datum #'name)] [_ #f])) (and modname (eval stx) (namespace-require modname) (module->namespace modname))))) (inherit get-language-name) (define/public (get-users-language-name defs-text) (let* ([defs-port (open-input-text-editor defs-text)] [read-successfully? (with-handlers ((exn:fail? (λ (x) #f))) (read-language defs-port (λ () #f)) #t)]) (cond [read-successfully? (let* ([str (send defs-text get-text 0 (file-position defs-port))] [pos (regexp-match-positions #rx"#(?:!|lang )" str)]) (cond [(not pos) (get-language-name)] [else ;; newlines can break things (ie the language text won't ;; be in the right place in the interactions window, which ;; at least makes the test suites unhappy), so get rid of ;; them from the name. Otherwise, if there is some wierd formatting, ;; so be it. (regexp-replace* #rx"[\r\n]+" (substring str (cdr (car pos)) (string-length str)) " ")]))] [else (get-language-name)]))) (define/override (use-namespace-require/copy?) #f) (define/augment (capability-value key) (cond [(eq? key 'drscheme:autocomplete-words) (drracket:language-configuration:get-all-manual-keywords)] [else (drracket:language:get-capability-default key)])) ;; config-panel : as in super class ;; uses drracket: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)) ;; NOTE: this method is also used in the super class's implementation ;; of default-settings?, which is why the super call is appropriate ;; there, even tho these settings are not the same as the defaults ;; in other languages (here 'none is the default annotations, ;; there you get errortrace annotations). (define/override (default-settings) (let ([super-defaults (super default-settings)]) (make-module-language-settings #t 'print 'mixed-fraction-e #f #t 'debug;; simple settings defaults '(default) #() default-auto-text default-compilation-on? default-full-trace?))) ;; 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) #()) ;; Never show that this is a "custom" language because of the ;; auto-text ;; (equal? (module-language-settings-auto-text settings) ;; default-auto-text) (equal? (module-language-settings-compilation-on? settings) default-compilation-on?) (equal? (module-language-settings-full-trace? settings) default-full-trace?))) (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) (module-language-settings-auto-text settings) (module-language-settings-compilation-on? settings)))) (define/override (unmarshall-settings marshalled) (and (list? marshalled) (let ([marshalled-len (length marshalled)]) ;; older formats had no auto-text or compilation disabling (and (<= 3 marshalled-len) (let ([collection-paths (list-ref marshalled 1)] [command-line-args (list-ref marshalled 2)] [auto-text (if (<= marshalled-len 3) default-auto-text (list-ref marshalled 3))] [compilation-on? (if (<= marshalled-len 4) default-compilation-on? (list-ref marshalled 4))] [full-trace? (if (<= marshalled-len 5) default-full-trace? (list-ref marshalled 5))]) (and (list? collection-paths) (andmap (λ (x) (or (string? x) (symbol? x))) collection-paths) (vector? command-line-args) (andmap string? (vector->list command-line-args)) (string? auto-text) (boolean? compilation-on?) (let ([super (super unmarshall-settings (let ([p (car marshalled)]) ;; Convert 'write to 'print: (if (eq? (vector-ref p 1) 'write) (list->vector (list* (vector-ref p 0) 'print (cddr (vector->list p)))) p)))]) (and super (apply make-module-language-settings (append (vector->list (drracket:language:simple-settings->vector super)) (list collection-paths command-line-args auto-text ;; current versions of drscheme do not allow this combination ;; in the first place (compilation is only allowed in 'none ;; and 'debug mode), but older versions might. (and (memq (drracket:language:simple-settings-annotations super) '(none debug)) compilation-on?) full-trace?))))))))))) (define/override (on-execute settings run-in-user-thread) (super on-execute settings run-in-user-thread) ;; reset the language info so that if the module is illformed, ;; we don't save the language info from the last run (set! language-info #f) (set! sandbox #f) (run-in-user-thread (λ () (current-command-line-arguments (module-language-settings-command-line-args settings)) (let* ([default (current-library-collection-paths)] [cpaths (append-map (λ (x) (if (symbol? x) default (list x))) (module-language-settings-collection-paths settings))]) (when (null? cpaths) (fprintf (current-error-port) "WARNING: your collection paths are empty!\n")) (current-library-collection-paths cpaths)) (compile-context-preservation-enabled (module-language-settings-full-trace? settings)) (when (module-language-settings-compilation-on? settings) (let ([annotations (drracket:language:simple-settings-annotations settings)]) (case annotations [(none) (use-compiled-file-paths (cons (build-path "compiled" "drracket") (use-compiled-file-paths)))] [(debug) (use-compiled-file-paths (cons (build-path "compiled" "drracket" "errortrace") (use-compiled-file-paths)))])) (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler #t)) (let* ([cd (find-collects-dir)] [no-dirs (if cd (list (CACHE-DIR) cd) (list (CACHE-DIR)))]) (manager-skip-file-handler (λ (p) (file-stamp-in-paths p no-dirs)))))))) (define/override (get-one-line-summary) (string-constant module-language-one-line-summary)) (define/public (get-auto-text settings) (module-language-settings-auto-text settings)) ;; utility for the front-end method: return a function that will return ;; each of the given syntax values on each call, executing thunks when ;; included; when done with the list, send eof. (define (expr-getter . exprs/thunks) (define (loop) (if (null? exprs/thunks) eof (let ([x (car exprs/thunks)]) (set! exprs/thunks (cdr exprs/thunks)) (if (procedure? x) (begin (x) (loop)) x)))) loop) (inherit get-reader) (define repl-init-thunk (make-thread-cell #f)) (define/override (front-end/complete-program port settings) (define (super-thunk) (define reader (get-reader)) (reader (object-name port) port)) (define path (cond [(get-filename port) => (compose simplify-path cleanse-path)] [else #f])) (define resolved-modpath (and path (module-path-index-resolve (module-path-index-join path #f)))) (define-values (name lang module-expr) (let ([expr ;; just reading the definitions might be a syntax error, ;; possibly due to bad language (eg, no foo/lang/reader) (with-handlers ([exn:fail? (λ (e) ;; [Eli] FIXME: use `read-language' on `port' after calling ;; `file-position' to reset it to the beginning (need to ;; make sure that it's always a seekable port), then see ;; the position that we're left at, re-read that part of ;; the port (a second reset), construct a string holding ;; the #lang, and read from it an empty module, and extract ;; the base module from it (ask Matthew about this). (raise-hopeless-exception e "invalid module text"))]) (super-thunk))]) (when (eof-object? expr) (raise-hopeless-syntax-error)) (let ([more (super-thunk)]) (unless (eof-object? more) (raise-hopeless-syntax-error "there can only be one expression in the definitions window" more))) (transform-module path expr))) (define modspec (or path `',(syntax-e name))) (define (check-interactive-language) (unless (memq '#%top-interaction (namespace-mapped-symbols)) (raise-hopeless-exception #f #f ; no error message, just a suffix (format "~s does not support a REPL (no #%top-interaction)" (syntax->datum lang))))) ;; We're about to send the module expression to drscheme now, the rest ;; of the setup is done in `front-end/finished-complete-program' below, ;; so use `repl-init-thunk' to store an appropriate continuation for ;; this setup. Once we send the expression, we'll be called again only ;; if it was evaluated (or expanded) with no errors, so begin with a ;; continuation that deals with an error, and if we're called again, ;; change it to a continuation that initializes the repl for the ;; module. So the code is split among several thunks that follow. (define (*pre) (thread-cell-set! repl-init-thunk *error) (current-module-declare-name resolved-modpath) (current-module-declare-source path)) (define (*post) (current-module-declare-name #f) (current-module-declare-source #f) (when path ((current-module-name-resolver) resolved-modpath)) (thread-cell-set! repl-init-thunk *init)) (define (*error) (current-module-declare-name #f) (current-module-declare-source #f) ;; syntax error => try to require the language to get a working repl (with-handlers ([void (λ (e) (raise-hopeless-syntax-error "invalid language specification" lang))]) (namespace-require lang)) (check-interactive-language)) (define (*init) (parameterize ([current-namespace (current-namespace)]) ;; the prompt makes it continue after an error (call-with-continuation-prompt (λ () (with-stack-checkpoint (begin (*do-module-specified-configuration) (namespace-require modspec)))))) (current-namespace (module->namespace modspec)) (check-interactive-language)) (define (*do-module-specified-configuration) (let ([info (module->language-info modspec #t)]) (parameterize ([current-eventspace drracket:init:system-eventspace]) (queue-callback (λ () (set! language-info info)))) (when info (let ([get-info ((dynamic-require (vector-ref info 0) (vector-ref info 1)) (vector-ref info 2))]) (let ([configs (get-info 'configure-runtime '())]) (for ([config (in-list configs)]) ((dynamic-require (vector-ref config 0) (vector-ref config 1)) (vector-ref config 2)))))))) ;; here's where they're all combined with the module expression (expr-getter *pre module-expr *post)) (define/override (front-end/finished-complete-program settings) (cond [(thread-cell-ref repl-init-thunk) => (λ (t) (thread-cell-set! repl-init-thunk #f) (t))])) (define/override (front-end/interaction port settings) (λ () (let ([v (parameterize ([read-accept-reader #t] [read-accept-lang #f]) (with-stack-checkpoint ((current-read-interaction) (object-name port) port)))]) (if (eof-object? v) v (let ([w (cons '#%top-interaction v)]) (if (syntax? v) (namespace-syntax-introduce (datum->syntax #f w v)) v)))))) ;; printer settings are just ignored here. (define/override (create-executable setting parent program-filename) (let* ([executable-specs (drracket:language:create-executable-gui parent program-filename #t #t)]) (when executable-specs (let ([executable-type (list-ref executable-specs 0)] [gui? (eq? 'mred (list-ref executable-specs 1))] [executable-filename (list-ref executable-specs 2)]) (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))))]) (let ([call-create-embedding-executable (λ (exe-name) (let ([short-program-name (let-values ([(base name dir) (split-path program-filename)]) (path-replace-suffix name #""))]) (create-embedding-executable exe-name #:gracket? gui? #:verbose? #f #:modules (list (list #f program-filename)) #:configure-via-first-module? #t #:literal-expression (parameterize ([current-namespace (make-base-empty-namespace)]) (namespace-require 'racket/base) (compile `(namespace-require '',(string->symbol (path->string short-program-name))))) #:cmdline '("-U" "--"))))]) (case executable-type [(launcher) (let ([make-launcher (if gui? make-mred-launcher make-mzscheme-launcher)]) (make-launcher (list "-qt-" (path->string program-filename)) executable-filename))] [(distribution) (drracket:language:create-distribution-for-executable executable-filename gui? call-create-embedding-executable)] [(stand-alone) (call-create-embedding-executable executable-filename)]))))))) (super-new [module #f] [language-position (list (string-constant module-language-name))] [language-numbers (list -32768)]))) ;; can be called with #f to just kill the repl (in case we want to kill it ;; but keep the highlighting of a previous error) (define (raise-hopeless-exception exn [prefix #f] [suffix #f]) (define rep (drracket:rep:current-rep)) ;; Throw an error as usual if we don't have the drscheme rep, then we just ;; raise the exception as normal. (It can happen in some rare cases like ;; having a single empty scheme box in the definitions.) (unless rep (if exn (raise exn) (error "\nInteractions disabled"))) (when prefix (fprintf (current-error-port) "Module Language: ~a\n" prefix)) (when exn ((error-display-handler) (exn-message exn) exn)) ;; these are needed, otherwise the warning can appear before the output (flush-output (current-output-port)) (flush-output (current-error-port)) ;; do the rep-related work carefully -- using drscheme's eventspace, and ;; wait for it to finish before we continue. (let ([s (make-semaphore 0)] [msg (string-append "\nInteractions disabled" (if suffix (string-append ": " suffix) "."))]) (parameterize ([current-eventspace drracket:init:system-eventspace]) (queue-callback (λ () (send rep call-without-reset-highlighting (λ () (send* rep (insert-warning msg) (set-show-no-user-evaluation-message? #f)))) (semaphore-post s)))) (semaphore-wait s)) (custodian-shutdown-all (send rep get-user-custodian))) (define (raise-hopeless-syntax-error . error-args) (with-handlers ([exn:fail? raise-hopeless-exception]) (apply raise-syntax-error '|Module Language| (if (null? error-args) (list (string-append "There must be a valid module in the\n" "definitions window. Try starting your program with\n" "\n" " #lang racket\n" "\n" "and clicking ‘Run’.")) error-args)))) ;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void)) (define (module-language-config-panel parent) (define new-parent (new vertical-panel% [parent parent] [alignment '(center center)] [stretchable-height #f] [stretchable-width #f])) (define compilation-on-check-box #f) (define compilation-on? #t) (define save-stacktrace-on-check-box #f) (define left-debugging-radio-box #f) (define right-debugging-radio-box #f) (define simple-case-lambda (drracket:language:simple-module-based-language-config-panel new-parent #:case-sensitive #t #:get-debugging-radio-box (λ (rb-l rb-r) (set! left-debugging-radio-box rb-l) (set! right-debugging-radio-box rb-r)) #:debugging-radio-box-callback (λ (debugging-radio-box evt) (update-compilation-checkbox left-debugging-radio-box right-debugging-radio-box)) #:dynamic-panel-extras (λ (dynamic-panel) (set! compilation-on-check-box (new check-box% [label (string-constant automatically-compile)] [parent dynamic-panel] [callback (λ (_1 _2) (set! compilation-on? (send compilation-on-check-box get-value)))])) (set! save-stacktrace-on-check-box (new check-box% [label (string-constant preserve-stacktrace-information)] [parent dynamic-panel]))))) (define (update-compilation-checkbox left-debugging-radio-box right-debugging-radio-box) (case (send left-debugging-radio-box get-selection) [(0 1) (send compilation-on-check-box enable #t) (send compilation-on-check-box set-value compilation-on?)] [(#f) (send compilation-on-check-box enable #f) (send compilation-on-check-box set-value #f)])) (define cp-panel (new group-box-panel% [parent new-parent] [label (string-constant ml-cp-collection-paths)])) (define args-panel (new 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])) (define auto-text-panel (new group-box-panel% [parent new-parent] [label (string-constant module-language-auto-text)])) (define auto-text-text-box (new text-field% [parent auto-text-panel] [label #f] [init-value ""] [callback void])) ;; data associated with each item in listbox : boolean ;; indicates if the entry is the default paths. (define collection-paths-lb (new list-box% [parent cp-panel] [choices '("a" "b" "c")] [label #f] [callback (λ (x y) (update-buttons))])) (define button-panel (new 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) (move-callback -1)))) (define lower-button (make-object button% (string-constant ml-cp-lower) button-panel (λ (x y) (move-callback +1)))) (define (update-buttons) (let ([lb-selection (send collection-paths-lb get-selection)] [lb-tot (send collection-paths-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 collection-paths-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 collection-paths-lb append (string-constant ml-cp-default-collection-path) #t) (update-buttons)])) ;; has-default? : -> boolean ;; returns #t if the `default' entry has already been added (define (has-default?) (let loop ([n (send collection-paths-lb get-number)]) (cond [(= n 0) #f] [(send collection-paths-lb get-data (- n 1)) #t] [else (loop (- n 1))]))) (define (remove-callback) (let ([to-delete (send collection-paths-lb get-selection)]) (send collection-paths-lb delete to-delete) (unless (zero? (send collection-paths-lb get-number)) (send collection-paths-lb set-selection (min to-delete (- (send collection-paths-lb get-number) 1)))) (update-buttons))) (define (move-callback d) (let* ([sel (send collection-paths-lb get-selection)] [vec (get-lb-vector)] [new (+ sel d)] [other (vector-ref vec new)]) (vector-set! vec new (vector-ref vec sel)) (vector-set! vec sel other) (set-lb-vector vec) (send collection-paths-lb set-selection new) (update-buttons))) (define (get-lb-vector) (list->vector (for/list ([n (in-range (send collection-paths-lb get-number))]) (cons (send collection-paths-lb get-string n) (send collection-paths-lb get-data n))))) (define (set-lb-vector vec) (send collection-paths-lb clear) (for ([x (in-vector vec)] [n (in-naturals)]) (send collection-paths-lb append (car x)) (send collection-paths-lb set-data n (cdr x)))) (define (get-collection-paths) (for/list ([n (in-range (send collection-paths-lb get-number))]) (let ([data (send collection-paths-lb get-data n)]) (if data 'default (send collection-paths-lb get-string n))))) (define (install-collection-paths paths) (send collection-paths-lb clear) (for ([cp paths]) (if (symbol? cp) (send collection-paths-lb append (string-constant ml-cp-default-collection-path) #t) (send collection-paths-lb append cp #f)))) (define (get-command-line-args) (let* ([str (send args-text-box get-value)] [read-res (parameterize ([read-accept-graph #f]) (with-handlers ([exn:fail:read? (λ (x) #())]) (read (open-input-string str))))]) (if (and (vector? read-res) (andmap string? (vector->list read-res))) read-res #()))) (define (install-command-line-args vec) (send args-text-box set-value (parameterize ([print-vector-length #f]) (format "~s" vec)))) (define (get-auto-text) (let ([str (send auto-text-text-box get-value)]) (cond [(equal? str "") ""] [else (string-append str "\n")]))) (define (install-auto-text str) (send auto-text-text-box set-value (regexp-replace #rx"\n$" str ""))) (install-collection-paths '(default)) (update-buttons) (install-auto-text default-auto-text) (update-compilation-checkbox left-debugging-radio-box right-debugging-radio-box) (case-lambda [() (let ([simple-settings (simple-case-lambda)]) (apply make-module-language-settings (append (vector->list (drracket:language:simple-settings->vector simple-settings)) (list (get-collection-paths) (get-command-line-args) (get-auto-text) (case (send left-debugging-radio-box get-selection) [(0 1) compilation-on?] [(#f) #f]) (send save-stacktrace-on-check-box get-value)))))] [(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)) (install-auto-text (module-language-settings-auto-text settings)) (set! compilation-on? (module-language-settings-compilation-on? settings)) (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)) (update-buttons)])) ;; transform-module : (union #f path) syntax ;; -> (values syntax[name-of-module] syntax[lang-of-module] syntax[module]) ;; = User = (define (transform-module filename stx) (define-values (mod name lang body) (syntax-case stx () [(module name lang . body) (eq? 'module (syntax-e #'module)) (values #'module #'name #'lang #'body)] [_ (raise-hopeless-syntax-error (string-append "only a module expression is allowed, either\n" " #lang \n or\n" " (module ...)\n") stx)])) (define name* (syntax-e name)) (unless (symbol? name*) (raise-hopeless-syntax-error "bad syntax in name position of module" stx name)) (when filename (check-filename-matches filename name* stx)) (let* (;; rewrite the module to use the racket/base version of `module' [mod (datum->syntax #'here 'module mod)] [expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)]) (values name lang expr))) ;; 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 drracket: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 : path datum syntax -> void (define (check-filename-matches filename datum unexpanded-stx) (when #f ; we don't check filename matching anymore (let-values ([(base name dir?) (split-path filename)]) (let ([expected (string->symbol (path->string (path-replace-suffix name #"")))]) (unless (equal? expected datum) (raise-hopeless-syntax-error (format "module name doesn't match saved filename, got ~s and expected ~s" datum expected) unexpanded-stx)))))) (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 drracket:unit:frame<%>)) (let* ([definitions-text (send tlw get-definitions-text)] [module-language? (is-a? (drracket: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) ".rkt"))))))) (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))))