#lang racket/gui ;(require drracket/tool-lib) (require framework) #| TODO - sort the scripts in sub-menus, given in the prop-file |# (preferences:set-default 'user-script-dir (path->string (build-path (find-system-path 'pref-dir) "user-scripts")) path-string?) (define (script-dir) ;"/home/laurent/Unison/Prog/Racket/tool-test/scripts/") (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 frame (new frame:text% ;(drracket:frame:basics-mixin frame%) [min-width 400] [min-height 400])) (define menu-bar (send frame get-menu-bar));(new menu-bar% [parent frame])) (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 (dict-ref props 'shortcut-prefix (get-default-shortcut-prefix))] [help-string (dict-ref props 'help-string #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 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 (choose-script-dir) (let ([d (get-directory "Choose a directory for storing scripts" #f (script-dir))]) (displayln d) (and d (set-script-dir d)))) (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))))) (with-output-to-file f-script (λ _ (displayln "#lang racket/base"))) (edit-script f-script) ;(edit-script f-prop) )) ;; file: path? (define (edit-script file) (when file (define text (send frame get-editor)) (send text load-file 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 properties" frame (script-dir) #f #f '() '(("Property file" "*.rktd")))) (edit-script file) ) ;; f: path? (define (run-script f) (define text (send frame get-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)) (send text begin-edit-sequence) (send text insert str-out) (send text end-edit-sequence) ) (send frame show #t)