Copyright (c) 2012 Laurent Orseau (laurent orseau gmail com)

License: LGPL v3 or higher (

#lang racket/base

(require drracket/tool
         racket/pretty ; for pretty-write
         racket/path ; for filename-extension
         racket/runtime-path ; for the help menu
         (for-syntax racket/base) ; for help menu
         net/sendurl ; for the help menu
         framework ; for preferences (too heavy a package?)
         planet/version ; for bug report
(provide tool@)

#| TODO:
- import menu: allow to import only the rktd file (ask for overwrite for both files)
- rebuild the menu less often (only when the Script menu is clicked, not any menu)
- automatic testing with the framework
- the demand-callback is called each time the user clicks on a menu or when traversed
  when looking for a shortcut key binding. Each time this needs to recreate the menu
  and thus look at all the files in the directory. -> need to improve speed?
  Idea: recreate the menu only if at least one file has changed?
- auto-load (+ automatically persistent): a script is automatically run as soon as possible,
  no need to click on a menu. Usefull to add some menu to DrRacket?
  - may require to add a 'on-exit' method, that is run when 'Unload persistent scripts' is clicked.
- Test for new version of the plugin, and download it if 'yes. 
  (also add an option to avoid asking the question all the time if 'no)
- rename "examples" directory to "scripts" or "bundled-scripts"

- new file in same directory
- "command line" bar? Opens a small frame (with shortcut) where queries can be made
- Make an Overview frame for scrbl (or LaTeX) documents, with links to (sub)sections; 
  This could also be added as an automatically refreshed menu to DrRacket

#| Package managing:

; Development link:
(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` or `raco setup -P orseau script-plugin.plt 1 0`

; OR:
; `raco link script-plugin` in the parent directory
; `raco setup script-plugin`

; To build the package:
; OBSOLETE (in the parent directory):
$ raco planet create script-plugin
; CURRENT (in the plugin directory):
$ ./


(module+ main
  (require planet/util)
  (define (add-link)
    (displayln "Adding hard link.")
    (add-hard-link "orseau" "script-plugin.plt" 1 0 (current-directory))
    ;(remove-hard-link "orseau" "script-plugin.plt" 1 0)
    (displayln "Now run 'raco setup -P orseau script-plugin.plt 1 0'"))

(define-runtime-path help-path
  (build-path "planet-docs" "manual" "index.html"))

(define-runtime-path examples-path
  (build-path "examples"))

(define base-default-user-script-dir (find-system-path 'pref-dir))

(preferences:set-default 'user-script-dir
                         (path->string (build-path base-default-user-script-dir 

(define (script-dir)
  (preferences:get 'user-script-dir))

;(displayln (script-dir))

; Copy sample scripts at installation (or if user's script directory does not exist):
(unless (directory-exists? (script-dir))
  (make-directory* base-default-user-script-dir)
  ;(message-box "copy scripts" "The scripts are being copied to your user directory")
  (copy-directory/files examples-path (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
    ;(displayln d)
    (when d (set-script-dir d))))

(define (error-message-box filename e)
  (message-box filename
               (format "Error in script file ~s: ~a" filename (exn-message e))
               #f '(stop ok)))

(define-namespace-anchor a)

;; the preference panel is automatically added by DrRacket (nice feature!)
   (define pref-panel (new vertical-panel% [parent parent] 
                           [alignment     '(center center)]
                           [spacing       10]
                           [horiz-margin  10]
                           [vert-margin   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)))

(define tool@
    (import drracket:tool^)
    (export drracket:tool-exports^)
    (define script-menu-mixin
      (mixin (drracket:unit:frame<%>) ()
        (inherit get-button-panel
        (define (get-the-text-editor)
          ; for a frame:text% :
          ;(define text (send frame get-editor))
          ; for DrRacket:
          (define defed (get-definitions-text))
          (if (send defed has-focus?)
        (define frame this)
        (define props-default
          `((functions . item-callback)
            (shortcut . #f)
            (shortcut-prefix . #f)
            (help-string . "Help String")
            (output-to . selection) ; outputs the result in a new tab
            (persistent . #f)
            (active . #t)
        (define (prop-dict-ref props key)
          (dict-ref props key (dict-ref props-default key)))
        (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 (cons `(label . ,name) props-default))))
            (with-output-to-file f-script
              (λ _ 
                 (string-join '("#lang racket/base\n"
                                "; Sample identity function:"
                                ";; string? -> (or/c string? #f)")
                (for-each pretty-write 
                          '((provide item-callback)
                            (define (item-callback str)
                (displayln "\n;; See the manual in the Script/Help menu for more information.")
            (edit-script f-prop)
            (edit-script f-script)
        ;; 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)
        ;; Ask the user for a script to import from the bundled script directory
        ;; (or any other directory for that matter).
        ;; Useful when new scripts have been added due to an update.
        (define (import-bundled-script)
          (define src-file (get-file "Open a script" frame examples-path #f #f '() 
                                     '(("Racket" "*.rkt"))))
          (when src-file
            (define src-dir     (path-only src-file))
            (define filename    (path->string (file-name-from-path src-file)))
            (define filenamed   (string-append filename "d"))
            (define src-filed   (build-path src-dir filenamed))
            (define dest-file   (build-path (script-dir) filename))
            (define dest-filed  (build-path (script-dir) filenamed))
            (define overwrite? (or (not (file-exists? dest-file))
                                   (eq? 'ok
                                          "The script " filename 
                                          " already exists in your script directory.\n"
                                          "Do you want to overwrite it?")
                                         '(caution ok-cancel)))))
            (when overwrite?
              (if (file-exists? src-filed)
                  (begin (copy-file src-file  dest-file  #t)
                         (copy-file src-filed dest-filed #t))
                  (message-box "Not a script" 
                               "This is not a script file (no associated .rktd file found)"
                               frame '(caution ok))))))

        ;; dict for persistent scripts:
        ;; the module is instaciated only once, and made available for future calls.
        (define namespace-dict (make-hash))
        (define (unload-persistent-scripts)
          (set! namespace-dict (make-hash)))
        ;; f: path?
        (define (run-script fun file output-to persistent?)
          ; 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)))
          ; Create a namespace for the script:
          (define (make-script-namespace)
            (define ns (make-base-empty-namespace))
            (for ([mod '(racket/class racket/gui/base)])
              (namespace-attach-module (namespace-anchor->empty-namespace a)
                                       mod ns))
          ; if the script is persistent, we try to load an existing namespace, or we create one.
          ; if not, we always create a new namespace.
          (define ns 
            (if persistent?
                (dict-ref! namespace-dict file make-script-namespace)

          (define file-str (path->string file))
          (define ed-file (send (get-definitions-text) get-filename))
          (define str-out
            (with-handlers ([exn:fail? (λ(e)(error-message-box 
                                             (path->string (file-name-from-path file))
              ; See HelpDesk for "Manipulating namespaces"
              (parameterize ([current-namespace ns])
                (let ([f (dynamic-require file fun)]
                      [kw-dict `((#:definitions   . ,(get-definitions-text))
                                 (#:interactions  . ,(get-interactions-text))
                                 (#:editor        . ,text)
                                 (#:file          . ,ed-file)
                                 (#:frame         . ,this))])
                  (let-values ([(_ kws) (procedure-keywords f)])
                    (let ([k-v (sort (map (λ(k)(assoc k kw-dict)) kws)
                                     keyword<? #:key car)])
                      (keyword-apply f (map car k-v) (map cdr k-v) str '())
          (define (insert-to-text text)
            ; Inserts the text, possibly overwriting the selection:
            (send text begin-edit-sequence)
            (send text insert str-out)
            (send text end-edit-sequence))
          ; DrRacket specific:
          (when (or (string? str-out) (is-a? str-out snip%)) ; do not modify the file if no output
            (case output-to
               (insert-to-text (get-the-text-editor))] ; get the newly created text
               (insert-to-text text)]
               (message-box "Ouput" str-out this)]
        (define (open-help)
          (send-url/file help-path))
        (define (bug-report)
            (this-package-version-owner) "%2F" (this-package-version-name) 
            "&planetversion=%28" (number->string (this-package-version-maj))
            "+" (number->string (this-package-version-min)) "%29"
            "&author=" (preferences:get 'drracket:email)
            "&pltversion=" (version)
            "&keywords=" (symbol->string (system-type 'os)) 
            ; could also add (system-type 'machine) for more info
        (define menu-bar (send this get-menu-bar))
        (define menu-reload-count 0)
        (define scripts-menu 
          (new menu% [parent menu-bar] [label "&Scripts"]))
        (define (reload-scripts-menu)
          (define secs (current-milliseconds))
          (set! menu-reload-count (add1 menu-reload-count))
          #;(printf "Script menu rebuild #~a..." menu-reload-count)
          ;; remove all scripts items, after the persistent ones:
          (for ([item (list-tail (send scripts-menu get-items) 2)])
            (printf "Deleting menu item ~a... " (send item get-label))
            (send item delete)
            (printf "Ok.\n")
          ;; add script items:
          ; the menu-hash holds the submenus, to avoid creating them more than once
          (define menu-hash (make-hash))
          ;for all scripts in the script directory:
          (for ([f (directory-list (script-dir))])
            (let ([f-prop (build-path (script-dir) (string-append (path->string f) "d"))])
              ; catch problems and display them in a message-box
              (with-handlers ([exn:fail? (λ(e)(error-message-box 
                                               (path->string (file-name-from-path f-prop))
                ; the script file must have an associated rktd file
                (when (and (member (filename-extension f) '(#"rkt"))
                           (file-exists? f-prop))
                  ; read from the property file
                  (with-input-from-file f-prop 
                    (λ _
                      ; for all dictionaries in the file:
                      (let loop ([props (read)]) 
                        (when (and (dict? props)      (prop-dict-ref  props 'active))
                          (let*([label                (dict-ref       props 'label (path->string f))]
                                [functions            (prop-dict-ref  props 'functions)]
                                [shortcut             (prop-dict-ref  props 'shortcut)]
                                [shortcut-prefix (or  (prop-dict-ref  props 'shortcut-prefix)
                                [help-string          (prop-dict-ref  props 'help-string)]
                                [output-to            (prop-dict-ref  props 'output-to)]
                                [persistent           (prop-dict-ref  props 'persistent)]
                                [parent-menu (if (list? functions)
                                                 (hash-ref! menu-hash label
                                                            ; create a sub-menu if necessary:
                                                            (λ _ 
                                                              (new menu% [parent scripts-menu]
                                                                   [label label])))
                                [label-functions (if (list? functions)
                                                     (list (list functions label)))]
                            ; for all functions in the dictionary:
                            (for ([fun   (map first  label-functions)]
                                  [label (map second label-functions)])
                              (if (eq? label 'separator)
                                  (new separator-menu-item% [parent parent-menu])
                                  ; create an item for this function:
                                  (new menu-item% [parent parent-menu] 
                                       [label            label]
                                       [shortcut         shortcut]
                                       [shortcut-prefix  shortcut-prefix]
                                       [help-string      help-string]
                                       [callback         (λ(it ev)
                                                           (run-script fun
                                                                       (build-path (script-dir) f)
                          ; next dict:
                          (loop (read))
          #;(printf "Ok. Took ~ams\n" (- (current-milliseconds) secs)))
        (define manage-menu (new menu% [parent scripts-menu] [label "Manage scripts"]))
        (for ([(lbl cbk) (in-dict `(("New script..."              . ,new-script)
                                    ("Open script..."             . ,open-script)
                                    ("Open script properties..."  . ,open-script-properties)
                                    ("Import bundled script..."   . ,import-bundled-script)
                                    (separator                    . #f)
                                    ("Reload scripts menu"        . ,reload-scripts-menu)
                                    ("Unload persistent scripts"  . ,unload-persistent-scripts)
                                    (separator                    . #f)
                                    ("Help"                       . ,open-help)
                                    ("Feedback/Bug report..."     . ,bug-report)
          (if (eq? lbl 'separator)
              (new separator-menu-item% [parent manage-menu])
              (new menu-item% [parent manage-menu] [label lbl]
                   [callback (λ _ (cbk))])))
        (new separator-menu-item% [parent scripts-menu])

    (define (phase1) (void))
    (define (phase2) (void))
    (drracket:get/extend:extend-unit-frame script-menu-mixin)