#lang racket/unit

(require racket/class
         racket/list
         racket/runtime-path
         racket/contract
         setup/getinfo
         mred
         framework
         framework/splash
         "drsig.rkt"
         "language-object-contract.rkt"
         mrlib/switchable-button
         string-constants)

(require (for-syntax racket/base racket/match
                     compiler/cm-accomplice))

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

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

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

;; candidate-tools : (listof installed-tool)
(define candidate-tools null)

;; 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)

;; 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)

;; load/invoke-all-tools : -> void
(define (load/invoke-all-tools phase1-extras phase2-extras)
  (rescan-installed-tools!)
  (set! current-phase 'loading-tools)
  (set! 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
   '(drracket-tools drracket-tool-icons drracket-tool-names drracket-tool-urls
     tools tool-icons tool-names tool-urls)))

;; installed-tools-for-directory : directory-record -> (list-of installed-tool)
(define (installed-tools-for-directory coll-dir)
  (append (installed-tools-for-directory/keys coll-dir 'tools 'tool-icons 'tool-names 'tool-urls #f)
          (installed-tools-for-directory/keys coll-dir 'drracket-tools 'drracket-tool-icons 'drracket-tool-names 'drracket-tool-urls #t)))

;; installed-tools-for-directory/keys : directory-record symbol symbol symbol symbol boolean -> (list-of installed-tool)
(define (installed-tools-for-directory/keys coll-dir tools-key tool-icons-key tool-names-key tool-urls-key drracket-tool?)
  (let ([table (with-handlers ((exn:fail? values))
                 (get-info/full (directory-record-path coll-dir)))])
    (cond
      [(not table)
       null]
      [(exn? table)
       (message-box (string-constant drscheme)
                    (format (string-constant error-loading-tool-title)
                            (directory-record-path coll-dir)
                            (let ([sp (open-output-string)])
                              (parameterize ([current-error-port sp]
                                             [current-error-port sp])
                                (drracket:init:original-error-display-handler (exn-message table) table))
                              (get-output-string sp)))
                    #f
                    '(ok stop))
       null]
      [else
       (let* ([tools (table tools-key (lambda () null))]
              [tool-icons (table tool-icons-key (lambda () (map (lambda (x) #f) tools)))]
              [tool-names (table tool-names-key (lambda () (map (lambda (x) #f) tools)))]
              [tool-urls (table tool-urls-key (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 drracket-tool?))
              tools tool-icons tool-names tool-urls))])))

;; candidate-tool? : installed-tool -> boolean
;; Predicate for tools selected for execution in this
;; run of DrRacket (depending on env variables and preferences)
(define candidate-tool?
  (cond
    [(getenv "PLTNOTOOLS")
     (printf "PLTNOTOOLS: skipping tools\n") (flush-output)
     (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) (flush-output)
            (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 'drracket:default-tools-configuration))

(define toolspref
  (case-lambda
    [() (preferences:get 'drracket:tools-configuration)]
    [(v) (preferences:set 'drracket: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)
                     (installed-tool-drracket? 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)
;;                       boolean
;;                    -> 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 drracket?)
  (let* ([icon-path 
          (cond
            [(string? icon-spec)
             (build-path coll-dir icon-spec)]
            [(and (list? icon-spec)
                  (andmap string? icon-spec))
             (apply collection-file-path 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) 
                        (if drracket?
                            (invoke-tool unit (string->symbol (or name (path->string coll-dir))))
                            (drracket:tools-drs:invoke-drs-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 tool-lib-src (collection-file-path "tool-lib.rkt" "drracket"))
       
       (define full-sexp
         (call-with-input-file tool-lib-src
           (λ (port)
             (parameterize ([read-accept-reader #t])
               (read port)))))

       (register-external-file tool-lib-src)
       
       (let loop ([sexp full-sexp])
         (match sexp
           [`((#%module-begin ,body ...))
            (loop body)]
           [`((provide/dr/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 
                                                'drracket 
                                                tool-name
                                                (quote name)
                                                (quote-syntax name))]))
                          name
                          ctc)
                body)]
           [`(,a . ,b) 
            (loop b)]
           [`()
            (error 'tools.rkt "did not find provide/dr/doc: ~a" 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 drracket:tool^) (export drracket:tool-exports^))
  (language-object-abstraction drracket:language:object/c #f)
  (wrap-tool-inputs 
   (let ()
     (define-values/invoke-unit unit@
       (import drracket:tool^) (export drracket:tool-exports^))
     (values phase1 phase2))
   tool-name))

;; show-error : string (union exn TST) -> void
(define (show-error title x)
  (parameterize ([drracket: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 (get-splash-eventspace)]
            [splash-canvas (get-splash-canvas)]
            [splash-width (get-splash-width)]
            [splash-height (get-splash-height)])
        
        (unless (and (eventspace? splash-eventspace)
                     (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 (- splash-height tool-bitmap-y tool-bitmap-size))])
               
               ;; add the bitmap, but centered at its position
               ;; (used to truncate the bitmap
               ;; if it was too large, but no longer)
               ((dynamic-require 'framework/splash 'add-splash-icon)
                bitmap
                (floor (+ tool-bitmap-x
                          (- (/ tool-bitmap-size 2)
                             (/ (send bitmap get-width) 2))))
                (floor (+ translated-tool-bitmap-y
                          (- (/ tool-bitmap-size 2)
                             (/ (send bitmap get-height) 2)))))
               
               (set! tool-bitmap-x (+ tool-bitmap-x tool-bitmap-size tool-bitmap-gap))
               (when ((+ tool-bitmap-x tool-bitmap-gap tool-bitmap-size) . > . splash-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) . > . splash-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 DrRacket 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 DrRacket.")))
     (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 DrRacket 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)))])
         (cond [(installed-tool-is-loaded? it)
                (string-append name " (loaded)")]
               [(not (memq it candidate-tools))
                (string-append name " (skipped)")]
               [else
                (string-append name " (failed to load)")])))
     (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)))
