#lang scheme/unit

(require mzlib/class
         mzlib/list
         mrlib/hierlist
         "sig.ss"
         "../preferences.ss"
         "../gui-utils.ss"
         mred/mred-sig
         scheme/path
         string-constants)

(import mred^
        [prefix finder: framework:finder^]
        [prefix group: framework:group^]
        [prefix text: framework:text^]
        [prefix frame: framework:frame^])
(export framework:handler^)
(init-depend framework:frame^)

(define-struct handler (name extension handler))

(define format-handlers '())

(define (make-insert-handler who name extension handler)
  (cond [(not (string? name))
         (error who "name was not a string")]
        [(not (or (procedure? extension)
                  (string? extension)
                  (and (list? extension) (andmap string? extension))))
         (error who
                "extension was not a string, list of strings, or a predicate")]
        [(not (procedure? handler))
         (error who "handler was not a function")]
        [else (make-handler name
                            (if (string? extension) (list extension) extension)
                            handler)]))

(define (insert-format-handler . args)
  (set! format-handlers
        (cons (apply make-insert-handler 'insert-format-handler args)
              format-handlers)))

(define (find-handler name handlers)
  (let/ec exit
    (let ([extension (if (string? name) (or (filename-extension name) "") "")])
      (for ([handler handlers])
        (let ([ext (handler-extension handler)])
          (when (or (and (procedure? ext) (ext name))
                    (and (pair? ext)
                         (ormap (λ (ext) (string=? ext extension))
                                ext)))
            (exit (handler-handler handler)))))
      #f)))

(define (find-format-handler name)
  (find-handler name format-handlers))

; Finding format & mode handlers by name
(define (find-named-handler name handlers)
  (let loop ([l handlers])
    (cond [(null? l) #f]
          [(string-ci=? (handler-name (car l)) name)
           (handler-handler (car l))]
          [else (loop (cdr l))])))

(define (find-named-format-handler name)
  (find-named-handler name format-handlers))

; Open a file for editing
(define current-create-new-window
  (make-parameter
   (λ (filename)
     (let ([frame (make-object frame:text% filename)])
       (send frame show #t)
       frame))))

(define (edit-file filename [make-default
                             (λ () ((current-create-new-window) filename))])
  (with-handlers ([(λ (x) #f) ;exn:fail?
                   (λ (exn)
                     (message-box
                      (string-constant error-loading)
                      (string-append
                       (format (string-constant error-loading-file/name)
                               (or filename
                                   (string-constant unknown-filename)))
                       "\n\n"
                       (if (exn? exn)
                         (format "~a" (exn-message exn))
                         (format "~s" exn))))
                     #f)])
    (gui-utils:show-busy-cursor
     (λ ()
       (if filename
         (let ([already-open (send (group:get-the-frame-group)
                                   locate-file
                                   filename)])
           (cond
             [already-open
              (send already-open make-visible filename)
              (send already-open show #t)
              already-open]
             [(and (preferences:get 'framework:open-here?)
                   (send (group:get-the-frame-group) get-open-here-frame))
              =>
              (λ (fr)
                (add-to-recent filename)
                (send fr open-here filename)
                (send fr show #t)
                fr)]
             [else
              (let ([handler (and (path? filename)
                                  (find-format-handler filename))])
                (add-to-recent filename)
                (if handler (handler filename) (make-default)))]))
         (make-default))))))

;; type recent-list-item = (list/p string? number? number?)

;; add-to-recent : path -> void
(define (add-to-recent filename)
  (let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
         [old-ents (filter (λ (x) (string=? (path->string (car x))
                                            (path->string filename)))
                           old-list)]
         [old-ent (if (null? old-ents)
                      #f
                      (car old-ents))]
         [new-ent (list filename
                        (if old-ent (cadr old-ent) 0)
                        (if old-ent (caddr old-ent) 0))]
         [added-in (cons new-ent
                         (remove new-ent old-list compare-recent-list-items))]
         [new-recent (size-down added-in
                                (preferences:get 'framework:recent-max-count))])
    (preferences:set 'framework:recently-opened-files/pos new-recent)))

;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
(define (compare-recent-list-items l1 l2)
  (equal? (car l1) (car l2)))

;; size-down : (listof X) -> (listof X)[< recent-max-count]
;; takes a list of stuff and returns the
;; front of the list, up to `recent-max-count' items
(define (size-down new-recent n)
  (let loop ([n n] [new-recent new-recent])
    (cond [(zero? n) null]
          [(null? new-recent) null]
          [else (cons (car new-recent)
                      (loop (- n 1) (cdr new-recent)))])))

;; size-recently-opened-files : number -> void
;; sets the recently-opened-files/pos preference
;; to a size limited by `n'
(define (size-recently-opened-files n)
  (preferences:set
   'framework:recently-opened-files/pos
   (size-down (preferences:get 'framework:recently-opened-files/pos)
              n)))

;; set-recent-position : path number number -> void
;; updates the recent menu preferences
;; with the positions `start' and `end'
(define (set-recent-position filename start end)
  (let* ([recent-items
          (preferences:get 'framework:recently-opened-files/pos)]
         [new-recent-items
          (map (λ (x)
                 (if (string=? (path->string (car x))
                               (path->string filename))
                     (list* (car x) start end (cdddr x))
                     x))
               (preferences:get 'framework:recently-opened-files/pos))])
    (unless (equal? recent-items new-recent-items)
      (preferences:set 'framework:recently-opened-files/pos
                       new-recent-items))))

;; install-recent-items : (is-a?/c menu%) -> void?
(define (install-recent-items menu)
  (let ([recently-opened-files
         (preferences:get
          'framework:recently-opened-files/pos)])
    (for ([item (send menu get-items)]) (send item delete))

    (for ([recent-list-item recently-opened-files])
      (let ([filename (car recent-list-item)])
        (new menu-item%
          [parent menu]
          [label (gui-utils:trim-string
                  (regexp-replace* #rx"&" (path->string filename) "\\&\\&")
                  200)]
          [callback (λ (x y) (open-recent-list-item recent-list-item))])))
    (new separator-menu-item% [parent menu])
    (new menu-item%
      [parent menu]
      [label (string-constant show-recent-items-window-menu-item)]
      [callback (λ (x y) (show-recent-items-window))])
    (void)))

;; open-recent-list-item : recent-list-item -> void
(define (open-recent-list-item recent-list-item)
  (let* ([filename (car recent-list-item)]
         [start (cadr recent-list-item)]
         [end (caddr recent-list-item)])
    (cond
      [(file-exists? filename)
       (let ([fr (edit-file filename)])
         (when (is-a? fr frame:open-here<%>)
           (let ([ed (send fr get-open-here-editor)])
             (when (equal? (send ed get-filename) filename)
               (send ed set-position start end)))))]
      [else
       (message-box (string-constant error)
                    (format (string-constant cannot-open-because-dne)
                            filename))])))

;; show-recent-items-window : -> void
(define (show-recent-items-window)
  (unless recent-items-window
    (set! recent-items-window (make-recent-items-window)))
  (send recent-items-window show #t))

;; make-recent-items-window : -> frame
(define (make-recent-items-window)
  (make-object (get-recent-items-window%)
    (string-constant show-recent-items-window-label)
    #f
    (preferences:get 'framework:recent-items-window-w)
    (preferences:get 'framework:recent-items-window-h)))

;; recent-items-window : (union #f (is-a?/c frame%))
(define recent-items-window #f)

(define recent-items-hierarchical-list%
  (class hierarchical-list%
    (define/override (on-double-select item)
      (send item open-item))
    (super-instantiate ())))

(define recent-items-super% (frame:standard-menus-mixin frame:basic%))

(define (set-recent-items-frame-superclass super%)
  (set! recent-items-super% super%))

(define (get-recent-items-window%)
  (class recent-items-super%

    ;; remove extraneous separators
    (define/override (file-menu:between-print-and-close menu) (void))
    (define/override (edit-menu:between-find-and-preferences menu) (void))

    (define/override (on-size w h)
      (preferences:set 'framework:recent-items-window-w w)
      (preferences:set 'framework:recent-items-window-h h))

    ;; refresh-hl : (listof recent-list-item) -> void
    (define/private (refresh-hl recent-list-items)
      (let ([ed (send hl get-editor)])
        (send ed begin-edit-sequence)
        (for ([item (send hl get-items)]) (send hl delete-item item))
        (for-each (λ (item) (add-recent-item item))
                  (if (eq? (preferences:get 'framework:recently-opened-sort-by)
                           'name)
                    (sort recent-list-items string<?
                          #:key (compose path->string car) #:cache-keys? #t)
                    recent-list-items))
        (send ed end-edit-sequence)))

    (define/private (add-recent-item recent-list-item)
      (let ([item (send hl
                        new-item (make-hierlist-item-mixin recent-list-item))])
        (send (send item get-editor)
              insert (path->string (car recent-list-item)))))

    (field [remove-prefs-callback
            (preferences:add-callback 'framework:recently-opened-files/pos
                                      (λ (p v) (refresh-hl v)))])

    (define/augment (on-close)
      (inner (void) on-close)
      (remove-prefs-callback)
      (set! recent-items-window #f))

    (super-new)

    (inherit get-area-container)
    (field [bp (make-object horizontal-panel% (get-area-container))]
           [hl (make-object recent-items-hierarchical-list%
                            (get-area-container) '())]
           [sort-by-name-button
            (make-object button%
              (string-constant recent-items-sort-by-name)
              bp
              (λ (x y) (set-sort-by 'name)))]
           [sort-by-age-button
            (make-object button%
              (string-constant recent-items-sort-by-age)
              bp
              (λ (x y) (set-sort-by 'age)))])

    (send bp stretchable-height #f)
    (send sort-by-name-button stretchable-width #t)
    (send sort-by-age-button stretchable-width #t)

    (define/private (set-sort-by flag)
      (preferences:set 'framework:recently-opened-sort-by flag)
      (case flag
        [(name)
         (send sort-by-age-button enable #t)
         (send sort-by-name-button enable #f)]
        [(age)
         (send sort-by-age-button enable #f)
         (send sort-by-name-button enable #t)])
      (refresh-hl (preferences:get 'framework:recently-opened-files/pos)))

    (set-sort-by (preferences:get 'framework:recently-opened-sort-by))))

;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist)
(define (make-hierlist-item-mixin recent-item)
  (λ (%)
    (class %
      (define/public (open-item)
        (open-recent-list-item recent-item))
      (super-instantiate ()))))

(define (open-file [directory #f])
  (let* ([parent (and (or (not (eq? 'macosx (system-type)))
                          (preferences:get 'framework:open-here?))
                      (get-top-level-focus-window))]
         [file
          (parameterize ([finder:dialog-parent-parameter parent])
            (finder:get-file directory))])
    (and file
         (edit-file file))))