#| Copyright (c) 2012 Laurent Orseau (laurent orseau gmail com) License: LGPL v3 (http://www.gnu.org/copyleft/lesser.html) |# #lang racket/base (require drracket/tool racket/class racket/gui/base racket/unit racket/file racket/pretty ; for pretty-write racket/path ; for filename-extension racket/dict framework ; for preferences (too heavy a package?) ) (provide tool@) #| TODO: - add: a script can provide several functions and a submenu is added for the script, with one function for each sub-item - fix?: for the shortcuts to work, the menu must have been generated. |# #| (require planet/util) (add-hard-link "orseau" "script-plugin.plt" 1 0 (current-directory)) ; once the package is ready for upload: (remove-hard-link "orseau" "script-plugin.plt" 1 0) ; then do a `raco setup` |# (preferences:set-default 'user-script-dir (path->string (build-path (find-system-path 'pref-dir) "user-scripts")) path-string?) (define (script-dir) (preferences:get 'user-script-dir)) ;(displayln (script-dir)) (make-directory* (script-dir)) (define (set-script-dir dir) (preferences:set 'user-script-dir (if (path? dir) (path->string dir) dir))) (define (choose-script-dir) (let ([d (get-directory "Choose a directory to store scripts" #f (script-dir))]) ; (displayln d) (and d (set-script-dir d)))) (define tool@ (unit (import drracket:tool^) (export drracket:tool-exports^) (define script-menu-mixin (mixin (drracket:unit:frame<%>) () (super-new) (inherit get-button-panel get-definitions-text ;register-toolbar-button create-new-tab ) (define (get-the-text-editor) ; for a frame:text% : ;(define text (send frame get-editor)) ; for DrRacket: (get-definitions-text) ) (define frame this) (define (new-script) (define name (get-text-from-user "Script name" "Enter the name of the script:")) (when name (define script-name (string-append name ".rkt")) (define f-script (build-path (script-dir) script-name)) (define f-prop (build-path (script-dir) (string-append script-name "d"))) (with-output-to-file f-prop (λ _ (pretty-write `((label . ,name) (sub-menu . #f) (shortcut . #f) (shortcut-prefix . #f) (help-string . "Help String") (new-tab . #f) ; outputs the result in a new tab )))) (with-output-to-file f-script (λ _ (displayln "#lang racket/base\n\n;; Sample identity function:") (for-each pretty-write '((provide transform-input-string) (define (transform-input-string str) str ))) )) (edit-script f-script) (edit-script f-prop) )) ;; file: path? (define (edit-script file) (when file ; For frame:text% : ;(send (get-the-text-editor) load-file file) ; For DrRacket: (send this open-in-new-tab file) )) (define (open-script) (define file (get-file "Open a script" frame (script-dir) #f #f '() '(("Racket" "*.rkt")))) (edit-script file) ) (define (open-script-properties) (define file (get-file "Open a script properties" frame (script-dir) #f #f '() '(("Property file" "*.rktd")))) (edit-script file) ) ;; f: path? (define (run-script f new-tab?) ; For frame:text% : ;(define text (send frame get-editor)) ; For DrRacket: (define text (get-the-text-editor)) (define str (send text get-text (send text get-start-position) (send text get-end-position))) (define ns (make-base-namespace)) (define str-out (eval `(begin (require (file ,(path->string f))) (transform-input-string ,str) ) ns)) ; DrRacket specific: (when new-tab? (create-new-tab) (set! text (get-the-text-editor))) ; Inserts the text, possibly overwriting the selection: (send text begin-edit-sequence) (send text insert str-out) (send text end-edit-sequence) ) (define menu-bar (send this get-menu-bar)) (define scripts-menu (new menu% [parent menu-bar] [label "&Scripts"] [demand-callback (λ(m) ;; remove all scripts items, after the persistent ones: (for ([item (list-tail (send scripts-menu get-items) 4)]) (send item delete)) ;; add script items: (define menu-hash (make-hash)) (for ([f (directory-list (script-dir))]) (let ([f-prop (build-path (script-dir) (string-append (path->string f) "d"))]) (when (and (member (filename-extension f) '(#"rkt")) (file-exists? f-prop)) (let* ([props (with-input-from-file f-prop (λ _ (read)))] ; read from the property file [label (dict-ref props 'label (path->string f))] [sub-menu (dict-ref props 'sub-menu #f)] [parent-menu (if (string? sub-menu) (hash-ref! menu-hash sub-menu (λ _ (new menu% [parent scripts-menu] [label sub-menu]))) scripts-menu)] [shortcut (dict-ref props 'shortcut #f)] [shortcut-prefix (or (dict-ref props 'shortcut-prefix #f) (get-default-shortcut-prefix))] [help-string (dict-ref props 'help-string #f)] [new-tab? (dict-ref props 'new-tab #f)] ) (new menu-item% [parent parent-menu] [label label] [shortcut shortcut] [shortcut-prefix shortcut-prefix] [help-string help-string] [callback (λ(it ev)(run-script (build-path (script-dir) f) new-tab?))]))) )))] )) (new menu-item% [parent scripts-menu] [label "New Script"] [callback (λ _ (new-script))]) (new menu-item% [parent scripts-menu] [label "Open Script"] [callback (λ _ (open-script))]) (new menu-item% [parent scripts-menu] [label "Open Script Properties"] [callback (λ _ (open-script-properties))]) (new separator-menu-item% [parent scripts-menu]) (preferences:add-panel "Scripts" (λ(parent) (define pref-panel (new vertical-panel% [parent parent] [alignment '(center center)] [spacing 10] [horiz-margin 10] [vert-margin 10] ;[min-width 400] [min-height 400] ;[border 10] )) (define dir-panel (new horizontal-panel% [parent pref-panel])) (define text-dir (new text-field% [parent dir-panel] [label "Script directory:"] [init-value (script-dir)] [enabled #f])) (new button% [parent dir-panel] [label "Change script directory"] [callback (λ _ (choose-script-dir))]) (preferences:add-callback 'user-script-dir (λ(p v)(send text-dir set-value v))) pref-panel)) )) (define (phase1) (void)) (define (phase2) (void)) (drracket:get/extend:extend-unit-frame script-menu-mixin) ))