#lang scheme/base (provide module-language-tools@) (require mrlib/switchable-button mrlib/bitmap-label scheme/contract framework scheme/unit scheme/class scheme/gui/base "drsig.ss") (define-unit module-language-tools@ (import [prefix drscheme:unit: drscheme:unit^] [prefix drscheme:module-language: drscheme:module-language^] [prefix drscheme:language: drscheme:language^] [prefix drscheme:language-configuration: drscheme:language-configuration^]) (export drscheme:module-language-tools^) (define-local-member-name initialized? move-to-new-language) (define tab<%> (interface ())) (define tab-mixin (mixin (drscheme:unit:tab<%>) (tab<%>) (inherit get-frame) (define toolbar-buttons '()) (define/public (get-lang-toolbar-buttons) toolbar-buttons) (define/public (set-lang-toolbar-buttons bs) (for-each (λ (old-button) (send (get-frame) remove-toolbar-button old-button)) toolbar-buttons) (set! toolbar-buttons bs) (send (get-frame) register-toolbar-buttons toolbar-buttons)) (super-new))) (define frame<%> (interface ())) (define frame-mixin (mixin (drscheme:unit:frame<%>) (frame<%>) (inherit unregister-toolbar-button get-definitions-text) (define toolbar-button-panel #f) (define/public (initialized?) (and toolbar-button-panel #t)) (define/public (get-toolbar-button-panel) toolbar-button-panel) (define/public (remove-toolbar-button button) (send toolbar-button-panel change-children (λ (l) (remq button l))) (unregister-toolbar-button button)) (define/augment (on-tab-change old-tab new-tab) (inner (void) on-tab-change old-tab new-tab) (when toolbar-button-panel (send toolbar-button-panel change-children (λ (l) (send new-tab get-lang-toolbar-buttons))))) (super-new) (inherit get-button-panel) (set! toolbar-button-panel (new horizontal-panel% [parent (get-button-panel)] [stretchable-width #f])) ;; move button panel to the front of the list (send (get-button-panel) change-children (λ (l) (cons toolbar-button-panel (remq toolbar-button-panel l)))) (send (get-definitions-text) move-to-new-language))) (define definitions-text<%> (interface ())) (define definitions-text-mixin (mixin (text:basic<%> drscheme:unit:definitions-text<%>) (definitions-text<%>) (inherit get-next-settings) (define in-module-language? #f) ;; true when we are in the module language (define hash-lang-last-location #f) ;; non-false when we know where the hash-lang line ended (define hash-lang-language #f) ;; non-false is the string that was parsed for the language (define/augment (after-insert start len) (inner (void) after-insert start len) (modification-at start)) (define/augment (after-delete start len) (inner (void) after-delete start len) (modification-at start)) (define/private (modification-at start) (when (send (send (get-tab) get-frame) initialized?) (when in-module-language? (when (or (not hash-lang-last-location) (<= start hash-lang-last-location)) (move-to-new-language))))) (define/private (update-in-module-language? new-one) (unless (equal? new-one in-module-language?) (set! in-module-language? new-one) (cond [in-module-language? (move-to-new-language)] [else (clear-things-out)]))) (define/public (move-to-new-language) (let* ([port (open-input-text-editor this)] [info-result (with-handlers ((exn:fail? (λ (x) #f))) (parameterize ([current-reader-guard (let ([old (current-reader-guard)]) (lambda (g) (if (and (pair? g) (eq? (car g) 'planet)) (error "#lang planet disbled") (old g))))]) ;; FIXME: do something so that we don't ;; have to disable all planet packages. (read-language port (lambda () #f))))]) ;; sometimes I get eof here, but I don't know why and can't seem to ;; make it happen outside of DrScheme (when (eof-object? info-result) (fprintf (current-error-port) "file ~s produces eof from read-language\n" (send this get-filename)) (fprintf (current-error-port) " port-next-location ~s\n" (call-with-values (λ () (port-next-location port)) list)) (fprintf (current-error-port) " str ~s\n" (let ([s (send this get-text)]) (substring s 0 (min 100 (string-length s))))) (set! info-result #f)) (let-values ([(line col pos) (port-next-location port)]) (unless (equal? (get-text 0 pos) hash-lang-language) (set! hash-lang-language (get-text 0 pos)) (set! hash-lang-last-location pos) (clear-things-out) (when info-result (register-new-buttons (contract (or/c #f (listof (list/c string? (is-a?/c bitmap%) (-> (is-a?/c drscheme:unit:frame<%>) any)))) (info-result 'drscheme:toolbar-buttons #f) (get-lang-name pos) 'drscheme/private/module-language-tools))))))) (inherit get-tab) (define/private (register-new-buttons buttons) (when buttons (let* ([tab (get-tab)] [frame (send tab get-frame)]) (send tab set-lang-toolbar-buttons (map (λ (button-spec) (new switchable-button% [label (list-ref button-spec 0)] [bitmap (list-ref button-spec 1)] [parent (send frame get-toolbar-button-panel)] [callback (lambda (button) ((list-ref button-spec 2) frame))])) buttons))))) (inherit get-text) (define/private (get-lang-name pos) (cond [(zero? pos) '<>] [else (let ([str (get-text 0 pos)]) (if (char-whitespace? (string-ref str (- (string-length str) 1))) (substring str 0 (- (string-length str) 1)) str))])) ;; removes language-specific customizations (define/private (clear-things-out) (send (get-tab) set-lang-toolbar-buttons '())) (define/augment (after-set-next-settings settings) (update-in-module-language? (is-a? (drscheme:language-configuration:language-settings-language settings) drscheme:module-language:module-language<%>)) (inner (void) after-set-next-settings settings)) (super-new) (set! in-module-language? (is-a? (drscheme:language-configuration:language-settings-language (get-next-settings)) drscheme:module-language:module-language<%>))))) #| #lang scheme/gui (require mrlib/switchable-button mrlib/bitmap-label drscheme/tool scheme/system setup/xref) (provide tool@) (define-namespace-anchor anchor) (define scribble-bm (make-object bitmap% 1 1)) (define tool@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) (define phase1 void) (define phase2 void) (define (make-new-unit-frame% super%) (class super% (inherit get-button-panel get-definitions-text) (super-instantiate ()) (define client-panel (new horizontal-pane% (parent (get-button-panel)))) (define (make-render-button label mode suffix extra-cmdline) (new switchable-button% [label label] [bitmap scribble-bm] [parent client-panel] [callback (lambda (button) (let* ([t (get-definitions-text)] [fn (send t get-filename)]) (if fn (begin (send t save-file) (parameterize ([current-namespace (make-base-namespace)] [current-command-line-arguments (list->vector (append extra-cmdline (list mode (if (path? fn) (path->string fn) fn))))]) (namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref) (dynamic-require 'scribble/run #f) (let-values ([(base name dir?) (split-path fn)]) (system (format "open ~a" (path-replace-suffix name suffix)))))) (message-box "Not Named" "Cannot render unsaved file"))))])) (inherit register-toolbar-button) (define pdf-button (make-render-button "PDF" "--pdf" #".pdf" null)) (register-toolbar-button pdf-button) (define html-button (make-render-button "HTML" "--html" #".html" '("++xref-in" "setup/xref" "load-collections-xref"))) (register-toolbar-button html-button) (send (get-button-panel) change-children (lambda (l) (cons client-panel (remq client-panel l)))))) (drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f))) |#