
#lang scheme/unit

(require (lib "getinfo.ss" "setup")
         mred
         scheme/class
         scheme/list
         "drsig.ss"
         "language-object-contract.ss"
         scheme/contract
         framework
         string-constants
         scheme/runtime-path)

(require (for-syntax scheme/base scheme/match))

(import [prefix drscheme:frame: drscheme:frame^]
        [prefix drscheme:unit: drscheme:unit^]
        [prefix drscheme:rep: drscheme:rep^]
        [prefix drscheme:get/extend: drscheme:get/extend^]
        [prefix drscheme:language: drscheme:language^]
        [prefix drscheme:language-configuration: drscheme:language-configuration^]
        [prefix drscheme:help-desk: drscheme:help-desk^]
        [prefix drscheme:init: drscheme:init^]
        [prefix drscheme:debug: drscheme:debug^]
        [prefix drscheme:eval: drscheme:eval^]
        [prefix drscheme:modes: drscheme:modes^])
(export drscheme:tools^)

;; An installed-tool is
;; (make-installed-tool directory-record module-spec string/#f string/#f string/#f string/#f)
(define-struct installed-tool (dir spec bitmap name url))

;; installed-tools : (list-of installed-tool)
(define installed-tools null)

;; successful-tool = (make-successful-tool module-spec 
;;                                         (union #f (instanceof bitmap%))
;;                                         (union #f string)
;;                                         (union #f string))
(define-struct successful-tool (spec bitmap name url))

;; successful-tools : (listof successful-tool)
(define successful-tools null)

;; get-successful-tools : -> (listof successful-tool)
(define (get-successful-tools) successful-tools)

;; successfully-loaded-tool = 
;; (make-successfully-loaded-tool 
;;    module-spec (union #f (instanceof bitmap%)) (union #f string) (union #f string)
;;    (-> void) (-> void))
(define-struct successfully-loaded-tool (spec bitmap name url phase1 phase2))

;; successfully-loaded-tools : (listof successfully-loaded-tool)
;; this list contains the tools that successfully were loaded
;; it is updated in load/invoke-tool. 
(define successfully-loaded-tools null)

;; load/invoke-all-tools : -> void
(define (load/invoke-all-tools phase1-extras phase2-extras)
  (rescan-installed-tools!)
  (set! current-phase 'loading-tools)
  (let ([candidate-tools (filter candidate-tool? installed-tools)])
    (for-each load/invoke-tool candidate-tools)
    (run-phases phase1-extras phase2-extras)))

;; rescan-installed-tools! : -> void
(define (rescan-installed-tools!)
  (set! installed-tools (all-installed-tools)))

;; all-installed-tools : -> (list-of installed-tool)
(define (all-installed-tools)
  (apply append
         (map installed-tools-for-directory
              (all-tool-directories))))

;; all-tool-directories : -> (list-of directory-record)
(define (all-tool-directories)
  (find-relevant-directory-records '(tools tool-icons tool-names tool-urls)))

;; installed-tools-for-directory : directory-record -> (list-of installed-tool)
(define (installed-tools-for-directory coll-dir)
  (let ([table (get-info/full (directory-record-path coll-dir))])
    (if table
        (let* ([tools (table 'tools (lambda () null))]
               [tool-icons (table 'tool-icons (lambda () (map (lambda (x) #f) tools)))]
               [tool-names (table 'tool-names (lambda () (map (lambda (x) #f) tools)))]
               [tool-urls (table 'tool-urls (lambda () (map (lambda (x) #f) tools)))])
          (unless (= (length tools) (length tool-icons))
            (message-box (string-constant drscheme)
                         (format (string-constant tool-tool-icons-same-length)
                                 coll-dir tools tool-icons)
                         #f
                         '(ok stop))
            (set! tool-icons (map (lambda (x) #f) tools)))
          (unless (= (length tools) (length tool-names))
            (message-box (string-constant drscheme)
                         (format (string-constant tool-tool-names-same-length)
                                 coll-dir tools tool-names)
                         #f
                         '(ok stop))
            (set! tool-names (map (lambda (x) #f) tools)))
          (unless (= (length tools) (length tool-urls))
            (message-box (string-constant drscheme)
                         (format (string-constant tool-tool-urls-same-length)
                                 coll-dir tools tool-urls)
                         #f
                         '(ok stop))
            (set! tool-urls (map (lambda (x) #f) tools)))
          (map (lambda (t i n u) (make-installed-tool coll-dir t i n u))
               tools tool-icons tool-names tool-urls))
        null)))

;; candidate-tool? : installed-tool -> boolean
;; Predicate for tools selected for execution in this
;; run of DrScheme (depending on env variables and preferences)
(define candidate-tool?
  (cond
    [(getenv "PLTNOTOOLS")
     (printf "PLTNOTOOLS: skipping tools\n")
     (lambda (it) #f)]
    [(getenv "PLTONLYTOOL") =>
                            (lambda (onlys)
                              (let* ([allowed (let ([exp (read (open-input-string onlys))])
                                                (cond 
                                                  [(symbol? exp) (list exp)]
                                                  [(pair? exp) exp]
                                                  [else '()]))]
                                     [directory-ok? (lambda (x) 
                                                      (let-values ([(base name dir) (split-path x)])
                                                        (memq (string->symbol (path->string name))
                                                              allowed)))])
                                (printf "PLTONLYTOOL: only loading ~s\n" allowed)
                                (lambda (it)
                                  (directory-ok?
                                   (directory-record-path
                                    (installed-tool-dir it))))))]
    [else
     (lambda (it)
       (eq? (or (get-tool-configuration it)
                (default-tool-configuration it))
            'load))]))

;; get-tool-configuration : installed-tool -> symbol/#f
;; Get tool configuration preference or #f if no preference set.
(define (get-tool-configuration it)
  (let ([p (assoc (installed-tool->key it) (toolspref))])
    (and p (cadr p))))

;; default-tool-configuration : installed-tool -> (union 'load 'skip)
(define (default-tool-configuration it)
  (preferences:get 'drscheme:default-tools-configuration))

(define toolspref
  (case-lambda
    [() (preferences:get 'drscheme:tools-configuration)]
    [(v) (preferences:set 'drscheme:tools-configuration v)]))

(define (installed-tool->key it)
  (list (directory-record-spec (installed-tool-dir it))
        (installed-tool-spec it)))

(define (installed-tool-full-path it)
  (apply build-path
         (directory-record-path (installed-tool-dir it))
         (let ([path-parts (installed-tool-spec it)])
           (cond [(list? path-parts)
                  (append (cdr path-parts) (list (car path-parts)))]
                 [else (list path-parts)]))))

(define (installed-tool->module-spec it)
  (let* ([dirrec (installed-tool-dir it)]
         [key (directory-record-spec dirrec)]
         [maj (directory-record-maj dirrec)]
         [min (directory-record-min dirrec)]
         [parts (let ([parts0 (installed-tool-spec it)])
                  (if (list? parts0)
                      parts0
                      (list parts0)))]
         [file (car parts)]
         [rest-parts (cdr parts)])
    (case (car key)
      ((lib)
       `(lib ,(string-append
               (apply string-append
                      (map (lambda (s)
                             (string-append s "/"))
                           (append (cdr key) rest-parts)))
               file)))
      ((planet)
       `(planet ,file (,@(cdr key) ,maj ,min) ,@rest-parts)))))

;; installed-tool-is-loaded : installed-tool -> boolean
(define (installed-tool-is-loaded? it)
  (let ([path (installed-tool-full-path it)])
    (ormap (lambda (st) (equal? path (successful-tool-spec st)))
           (get-successful-tools))))


;                                                                                        
;                                                                                        
;                                                                                        
;  ;;;;                        ;;;;  ;;  ;;                             ;;;;             
;  ;;;;                        ;;;;  ;;  ;;                             ;;;;             
;  ;;;;   ;;;;   ;;;;;;;    ;;;;;;;  ;;     ;;;; ;;;  ;;;  ;;;   ;;;;   ;;;; ;;;   ;;;   
;  ;;;;  ;;;;;;  ;;;;;;;;  ;;;;;;;;  ;;;;;; ;;;;;;;;; ;;;  ;;;  ;;;;;;  ;;;; ;;;  ;;;;;  
;  ;;;; ;;;;;;;;     ;;;; ;;;;;;;;;  ;;;;;; ;;;; ;;;;  ;;;;;;  ;;;;;;;; ;;;;;;;  ;;;; ;; 
;  ;;;; ;;;; ;;;  ;;;;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;;  ;;;;;;  ;;;; ;;; ;;;;;;;  ;;;;;;; 
;  ;;;; ;;;;;;;; ;;  ;;;; ;;;;;;;;; ;; ;;;; ;;;; ;;;;  ;;;;;;  ;;;;;;;; ;;;; ;;; ;;;;;   
;  ;;;;  ;;;;;;  ;;;;;;;;  ;;;;;;;; ;; ;;;; ;;;; ;;;;   ;;;;    ;;;;;;  ;;;; ;;;  ;;;;;; 
;  ;;;;   ;;;;    ;; ;;;;   ;;;;;;; ;; ;;;; ;;;; ;;;;   ;;;;     ;;;;   ;;;; ;;;   ;;;;  
;                                   ;;                                                   
;                                                                                        
;                                                                                        



;; load/invoke-tool : installed-tool -> void
(define (load/invoke-tool it)
  (load/invoke-tool* (directory-record-path (installed-tool-dir it))
                     (installed-tool-spec it)
                     (installed-tool-bitmap it)
                     (installed-tool-name it)
                     (installed-tool-url it)))

;; load/invoke-tool* :   path
;;                       (listof string[sub-collection-name]) 
;;                       (union #f (cons string[filename] (listof string[collection-name])))
;;                       (union #f string)
;;                       (union #f string)
;;                    -> void
;; `coll' is a collection to load the tool from
;; `in-path' is the `coll'-relative collection-path spec for the tool module file
;; `icon-spec' is the collection-path spec for the tool's icon, if there is one.
;; `name' is the name of the tool (only used in about box)
(define (load/invoke-tool* coll-dir in-path icon-spec name tool-url)
  (let* ([icon-path 
          (cond
            [(string? icon-spec)
             (build-path coll-dir icon-spec)]
            [(and (list? icon-spec)
                  (andmap string? icon-spec))
             (build-path (apply collection-path (cdr icon-spec)) (car icon-spec))]
            [else #f])]
         [tool-bitmap
          (and icon-path
               (install-tool-bitmap name icon-path))])
    (let/ec k
      (unless (or (string? in-path)
                  (and (list? in-path)
                       (not (null? in-path))
                       (andmap string? in-path)))
        (message-box (string-constant drscheme)
                     (format (string-constant invalid-tool-spec)
                             coll-dir in-path)
                     #f
                     '(ok stop))
        (k (void)))
      (let* ([tool-path
              (if (string? in-path) 
                  (build-path coll-dir in-path)
                  (apply build-path coll-dir (append (cdr in-path) (list (car in-path)))))]
             [unit 
               (with-handlers ([exn:fail? 
                                (lambda (x)
                                  (show-error
                                   (format (string-constant error-invoking-tool-title)
                                           coll-dir in-path)
                                   x)
                                  (k (void)))])
                 (dynamic-require tool-path 'tool@))])
        (with-handlers ([exn:fail? 
                         (lambda (x)
                           (show-error 
                            (format (string-constant error-invoking-tool-title)
                                    coll-dir in-path)
                            x))])
          (let-values ([(phase1-thunk phase2-thunk) 
                        (invoke-tool unit (string->symbol (or name (path->string coll-dir))))])
            (set! successfully-loaded-tools 
                  (cons (make-successfully-loaded-tool
                         tool-path
                         tool-bitmap
                         name
                         tool-url 
                         phase1-thunk
                         phase2-thunk)
                        successfully-loaded-tools))))))))

(define-syntax (wrap-tool-inputs stx)
  (syntax-case stx ()
    [(_ body tool-name)
     (let ()
       (define full-sexp
         (call-with-input-file (build-path (collection-path "drscheme") "tool-lib.ss")
           (λ (port)
             (parameterize ([read-accept-reader #t])
               (read port)))))
       
       (let loop ([sexp full-sexp])
         (match sexp
           [`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...)
            #`(let #,(map (λ (name ctc) 
                            (with-syntax ([name (datum->syntax #'tool-name name)]
                                          [ctc (datum->syntax #'tool-name ctc)])
                              #`[name (contract (let ([name ctc]) name)
                                                name 
                                                'drscheme 
                                                tool-name
                                                (quote-syntax name))]))
                          name
                          ctc)
                body)]
           [`(,a . ,b) 
            (loop b)]
           [`()
            (error 'tcl.ss "did not find provide/doc" full-sexp)])))]))

;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
;; invokes the tools and returns the two phase thunks.
(define (invoke-tool unit tool-name)
  (define-unit-binding unit@ unit (import drscheme:tool^) (export drscheme:tool-exports^))
  (language-object-abstraction drscheme:language:object/c #f)
  (wrap-tool-inputs 
   (let ()
     (define-values/invoke-unit unit@
       (import drscheme:tool^) (export drscheme:tool-exports^))
     (values phase1 phase2))
   tool-name))

;; show-error : string (union exn TST) -> void
(define (show-error title x)
  (parameterize ([drscheme:init:error-display-handler-message-box-title
                  title])
    ((error-display-handler)
     (if (exn? x)
         (format "~a\n\n~a" title (exn-message x))
         (format "~a\n\nuncaught exception: ~s" title x))
     x)))


;; install-tool-bitmap : string path -> bitmap
;; adds the tool's bitmap to the splash screen
(define (install-tool-bitmap name bitmap-path)
  (let/ec k
    (let ([bitmap
           (with-handlers ([exn:fail:filesystem? (lambda (x) (k (void)))])
             (make-object bitmap% bitmap-path 'unknown/mask))])
      (unless (and (is-a? bitmap bitmap%)
                   (send bitmap ok?))
        (k #f))
      (let ([splash-eventspace ((dynamic-require '(lib "framework/splash.ss") 'get-splash-eventspace))]
            [splash-bitmap ((dynamic-require '(lib "framework/splash.ss") 'get-splash-bitmap))]
            [splash-canvas ((dynamic-require '(lib "framework/splash.ss") 'get-splash-canvas))])
        
        (unless (and (eventspace? splash-eventspace)
                     (is-a? splash-bitmap bitmap%)
                     (send splash-bitmap ok?)
                     (is-a? splash-canvas canvas%))
          (k (void)))
        
        (parameterize ([current-eventspace splash-eventspace])
          (queue-callback
           (lambda ()
             (let ([bdc (make-object bitmap-dc%)]
                   [translated-tool-bitmap-y (max 0 (- (send splash-bitmap get-height) tool-bitmap-y tool-bitmap-size))])
               
               ;; truncate/expand the bitmap, if necessary
               (unless (and (= tool-bitmap-size (send bitmap get-width))
                            (= tool-bitmap-size (send bitmap get-height)))
                 (let ([new-b (make-object bitmap% tool-bitmap-size tool-bitmap-size #f)])
                   (send bdc set-bitmap new-b)
                   (send bdc clear)
                   (send bdc draw-bitmap-section splash-bitmap 
                         0 0 
                         tool-bitmap-x translated-tool-bitmap-y
                         tool-bitmap-size tool-bitmap-size)
                   (send bdc draw-bitmap bitmap 
                         (max 0 (- (/ tool-bitmap-size 2)
                                   (/ (send bitmap get-width) 2)))
                         (max 0 (- (/ tool-bitmap-size 2)
                                   (/ (send bitmap get-height) 2)))
                         'solid
                         (make-object color% "black")
                         (send bitmap get-loaded-mask))
                   (send bdc set-bitmap #f)
                   (set! bitmap new-b)))
               
               ((dynamic-require '(lib "framework/splash.ss") 'add-splash-icon)
                bitmap tool-bitmap-x translated-tool-bitmap-y)
               (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap))
               (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width))
                 (set! tool-bitmap-y (+ tool-bitmap-y tool-bitmap-size tool-bitmap-gap))
                 (set! tool-bitmap-x tool-bitmap-gap))
               (when ((+ tool-bitmap-y tool-bitmap-gap tool-bitmap-size) . > . (send splash-bitmap get-width))
                 (set! tool-bitmap-y tool-bitmap-gap)))))))
      bitmap)))

(define tool-bitmap-gap 3)
(define tool-bitmap-x tool-bitmap-gap)
(define tool-bitmap-y tool-bitmap-gap)
(define tool-bitmap-size 32)



;;                             ;                          ;;;  
;                           ;;;            ;;;          ;   ; 
;                             ;           ;  ;          ;   ; 
; ;;;   ; ;;   ;;;;    ;;;    ;;;     ;           ;             ;   ; 
;   ;  ;;  ;      ;  ;   ;  ;   ;    ;            ;   ;           ;  
;   ;  ;   ;   ;;;;   ;;;   ;;;;;    ;           ;;; ;           ;   
;   ;  ;   ;  ;   ;      ;  ;        ;          ;   ;           ;    
;   ;  ;   ;  ;   ;  ;   ;  ;   ;    ;          ;   ;;         ;   ; 
;;;;  ;;; ;;;  ;;; ;  ;;;    ;;;   ;;;;;         ;;;  ;        ;;;;; 
;                                                                    
;                                                                    
;;;                                                                   


;; run-phases : -> void
(define (run-phases phase1-extras phase2-extras)
  (let* ([after-phase1 (run-one-phase 'phase1
                                      (string-constant tool-error-phase1)
                                      successfully-loaded-tool-phase1
                                      successfully-loaded-tools
                                      phase1-extras)]
         [after-phase2 (run-one-phase 'phase2
                                      (string-constant tool-error-phase2)
                                      successfully-loaded-tool-phase2
                                      after-phase1
                                      phase2-extras)])
    (set! current-phase 'init-complete)
    (set! successful-tools
          (map (lambda (x) (make-successful-tool
                            (successfully-loaded-tool-spec x)
                            (successfully-loaded-tool-bitmap x)
                            (successfully-loaded-tool-name x)
                            (successfully-loaded-tool-url x)))
               after-phase2))))

;; run-one-phase : string 
;;                 (successfully-loaded-tool -> (-> void))
;;                 (listof successfully-loaded-tool)
;;                 (-> void)
;;              -> (listof successfully-loaded-tool)
;; filters out the tools that raise exceptions during the phase.
;; extras is the thunk for DrScheme init stuff on this phase.
(define (run-one-phase _the-phase err-fmt selector tools extras)
  (set! current-phase _the-phase)
  (extras)
  (let loop ([tools tools])
    (cond
      [(null? tools) null]
      [else 
       (let ([tool (car tools)])
         (let ([phase-thunk (selector tool)])
           (with-handlers ([exn:fail?
                            (lambda (exn) 
                              (show-error
                               (format err-fmt 
                                       (successfully-loaded-tool-spec tool)
                                       (successfully-loaded-tool-name tool))
                               exn)
                              (loop (cdr tools)))])
             (phase-thunk)
             (cons tool (loop (cdr tools))))))])))

;; current-phase : (union #f 'loading-tools 'phase1 'phase2 'init-complete)
(define current-phase #f)
(define (get-current-phase) current-phase)

;; only-in-phase : sym (union #f 'loading-tools 'phase1 'phase2 'init-complete) ... -> void
;; raises an error unless one of `phases' is the current phase
(define (only-in-phase func . phases)
  (unless (memq current-phase phases)
    (error func "can only be called in phase: ~a"
           (apply string-append 
                  (map (lambda (x) (format "~e " x))
                       (filter (lambda (x) x) phases))))))

;; Preferences GUI

(define load-action "Load the tool")
(define skip-action "Skip the tool")

(define (add-prefs-panel)
  (preferences:add-panel
   "Tools"
   (lambda (parent)
     (define main (new vertical-panel% (parent parent)))
     (define advisory
       (new message%
            (parent main)
            (label "Changes to tool configuration will take effect the next time you start DrScheme.")))
     (define listing
       (new list-box%
            (parent main)
            (label "Installed tools")
            (choices null)
            (callback (lambda _ (on-select-tool)))))
     (define info
       (new vertical-panel%
            (parent main)
            (style '(border))
            (stretchable-height #f)))
     (define location
       (new text-field%
            (parent info)
            (label "Tool: ")))
     (define location-editor (send location get-editor))
     (define configuration
       (new radio-box%
            (label "Load the tool when DrScheme starts?")
            (parent info)
            (choices (list load-action skip-action #| default-action |#))
            (callback (lambda _ (on-select-policy)))))
     
     (define (populate-listing!)
       (send listing clear)
       (for-each
        (lambda (entry+it)
          (send listing append
                (car entry+it)
                (cdr entry+it)))
        (sort (map (lambda (it) (cons (tool-list-entry it) it))
                   installed-tools)
              (lambda (a b)
                (string<? (car a) (car b))))))
     (define (tool-list-entry it)
       (let ([name (or (installed-tool-name it)
                       (format "unnamed tool ~a"
                               (installed-tool->module-spec it)))])
         (if (installed-tool-is-loaded? it)
             (string-append name " (loaded)")
             name)))
     (define (on-select-tool)
       (let ([it (get-selected-tool)])
         (send* location-editor
           (begin-edit-sequence)
           (lock #f)
           (erase)
           (insert
            (if it
                (format "~s" (installed-tool->module-spec it))
                ""))
           (lock #t)
           (end-edit-sequence))
         (send configuration set-selection
               (case (and it (get-tool-configuration it))
                 ((load) 0)
                 ((skip) 1)
                 ((#f) 0))) ;; XXX (or 2, if default is an option)
         (send configuration enable (and it #t))
         (void)))
     (define (on-select-policy)
       (let ([it (get-selected-tool)]
             [policy
              (case (send configuration get-selection)
                ((0) 'load)
                ((1) 'skip))])
         (when it
           (let ([key (installed-tool->key it)])
             (case policy
               ((load)
                (toolspref (cons (list key 'load)
                                 (let ([ts (toolspref)])
                                   (remove (assoc key ts) ts)))))
               ((skip)
                (toolspref (cons (list key 'skip)
                                 (let ([ts (toolspref)])
                                   (remove (assoc key ts) ts)))))
               ((#f)
                (toolspref (let ([ts (toolspref)])
                             (remove (assoc key ts) ts))))))))
       (void))
     (define (get-selected-tool)
       (let ([index (send listing get-selection)])
         (and index (send listing get-data index))))
     (populate-listing!)
     (send location-editor lock #t)
     main)))
