#|
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")
                                   (output-to . 'selection) ; outputs the result in a new tab
                                   (active . #t)
                                   ))))
            (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 output-to)
          ; 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))
          (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:
          (case output-to
            [(new-tab)
             (create-new-tab)
             (insert-to-text (get-the-text-editor))] ; get the newly created text
            [(selection)
             (insert-to-text text)]
            [(message-box)
             (message-box "Ouput" str-out this)]
            )
          )
        
        
        (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:
                  ; the menu-hash holds the submenus, to avoid creating them more than once
                  (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))
                        ; read from the property file
                        (let ([props (with-input-from-file f-prop (λ _ (read)))]) 
                          (when (dict-ref props 'active #t)
                            (let*([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)]
                                  [output-to (dict-ref props 'output-to 'selection)]
                                  )
                              (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)
                                                                  output-to))])
                              ))))
                      )))]
               ))
        (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])

        
        ;; the preference panel is automatically added by DrRacket (nice feature!)
        (preferences:add-panel 
         "Scripts"
         (λ(parent)
           (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)))
           pref-panel))
 
        ))
 
    (define (phase1) (void))
    (define (phase2) (void))
 
    (drracket:get/extend:extend-unit-frame script-menu-mixin)
    
    ))