(module editor mzscheme
  (require (lib "unitsig.ss")
	   (lib "class.ss")
           (lib "string-constant.ss" "string-constants")
	   "sig.ss"
	   "../gui-utils.ss"
           (lib "etc.ss")
	   (lib "mred-sig.ss" "mred")
	   (lib "file.ss"))

  (provide editor@)

  (define editor@
    (unit/sig framework:editor^
      (import mred^
	      [autosave : framework:autosave^]
	      [finder : framework:finder^]
	      [path-utils : framework:path-utils^]
	      [keymap : framework:keymap^]
	      [icon : framework:icon^]
	      [preferences : framework:preferences^]
	      [text : framework:text^]
	      [pasteboard : framework:pasteboard^]
	      [frame : framework:frame^]
              [handler : framework:handler^])

      (rename [-keymap<%> keymap<%>])

      ;; renaming, for editor-mixin where get-file is shadowed by a method.
      (define mred:get-file get-file) 

      (define basic<%>
	(interface (editor<%>)
	  has-focus?
	  local-edit-sequence?
	  run-after-edit-sequence
	  get-top-level-window
	  save-file-out-of-date?
          save-file/gui-error
          load-file/gui-error
          on-close
          can-close?
          close
          get-filename/untitled-name))

      (define basic-mixin
	(mixin (editor<%>) (basic<%>)
	  
          (define/pubment (can-close?) (inner #t can-close?))
          (define/pubment (on-close) (inner (void) on-close))
          (define/public (close) (if (can-close?)
                                     (begin (on-close) #t)
                                     #f))
          
          ;; get-filename/untitled-name : -> string
          ;; returns a string representing the visible name for this file,
          ;; or "Untitled <n>" for some n.
          (define untitled-name #f)
          (define/public (get-filename/untitled-name)
            (let ([filename (get-filename)])
              (if filename
                  (path->string filename)
                  (begin
                    (unless untitled-name
                      (set! untitled-name (gui-utils:next-untitled-name)))
                    untitled-name))))
          
	  (inherit get-filename save-file)
	  (define/public save-file/gui-error
	    (opt-lambda ([input-filename #f]
			 [fmt 'same]
			 [show-errors? #t])
              (let ([filename (if (or (not input-filename)
				      (equal? input-filename ""))
				  (let ([internal-filename (get-filename)])
				    (if (or (not internal-filename)
					    (equal? internal-filename ""))
					(put-file #f #f)
					internal-filename))
				  input-filename)])
                (with-handlers ([exn:fail?
                                 (λ (exn)
                                   (message-box
                                    (string-constant error-saving)
                                    (string-append
                                     (format (string-constant error-saving-file/name) 
                                             filename)
                                     "\n\n"
				     (format-error-message exn))
                                    #f
                                    '(stop ok))
                                   #f)])
                  (when filename
                    (save-file filename fmt #f))
                  #t))))
          
          (inherit load-file)
          (define/public load-file/gui-error
            (opt-lambda ([input-filename #f]
                         [fmt 'guess]
                         [show-errors? #t])
	      (let ([filename (if (or (not input-filename)
                                      (equal? input-filename ""))
                                  (let ([internal-filename (get-filename)])
                                    (if (or (not internal-filename)
                                            (equal? internal-filename ""))
                                        (get-file #f)
                                        internal-filename))
                                  input-filename)])
                (with-handlers ([exn:fail?
                                 (λ (exn)
                                   (message-box 
                                    (string-constant error-loading)
				    (string-append
				     (format (string-constant error-loading-file/name)
					     filename)
				     "\n\n"
				     (format-error-message exn))
                                    #f
                                    '(stop ok))
                                   #f)])
                  (load-file input-filename fmt show-errors?)
                  #t))))
	  
	  (define/private (format-error-message exn)
	    (let ([sp (open-output-string)])
	      (parameterize ([current-output-port sp])
		((error-display-handler)
		 (if (exn? exn)
		     (format "~a" (exn-message exn))
		     (format "uncaught exn: ~s" exn))
		 exn))
	      (get-output-string sp)))

	  (inherit refresh-delayed? 
		   get-canvas
		   get-max-width get-admin)
	  
	  (define/augment (can-save-file? filename format)
            (and (if (equal? filename (get-filename))
                     (if (save-file-out-of-date?)
                         (gui-utils:get-choice 
                          (string-constant file-has-been-modified)
                          (string-constant overwrite-file-button-label)
                          (string-constant cancel)
                          (string-constant warning)
                          #f
                          (get-top-level-window))
                         #t)
                     #t)
                 (inner #t can-save-file? filename format)))
	  
	  (define last-saved-file-time #f)
	  
	  (define/augment (after-save-file success?)
            ;; update recently opened file names
            (let* ([temp-b (box #f)]
                   [filename (get-filename temp-b)])
              (unless (unbox temp-b)
                (when filename
                  (handler:add-to-recent filename))))
            
            ;; update last-saved-file-time
            (when success?
              (let ([filename (get-filename)])
                (set! last-saved-file-time
                      (and filename
                           (file-exists? filename)
                           (file-or-directory-modify-seconds filename)))))
            
            (inner (void) after-save-file success?))
	  
	  (define/augment (after-load-file success?)
            (when success?
              (let ([filename (get-filename)])
                (set! last-saved-file-time
                      (and filename
                           (file-exists? filename)
                           (file-or-directory-modify-seconds filename)))))
            (inner (void) after-load-file success?))
	  (define/public (save-file-out-of-date?)
            (and last-saved-file-time
                 (let ([fn (get-filename)])
                   (and fn
                        (file-exists? fn)
                        (let ([ms (file-or-directory-modify-seconds fn)])
                          (< last-saved-file-time ms))))))
	  
	  (define has-focus #f)
	  (define/override (on-focus x)
            (set! has-focus x)
            (super on-focus x))
	  (define/public (has-focus?) has-focus)
	  
	  (define/public (get-top-level-window)
            (let loop ([text this])
              (let ([editor-admin (send text get-admin)])
                (cond
                  [(is-a? editor-admin editor-snip-editor-admin<%>)
                   (let* ([snip (send editor-admin get-snip)]
                          [snip-admin (send snip get-admin)])
                     (loop (send snip-admin get-editor)))]
                  [(send text get-canvas) 
                   => 
                   (λ (canvas)
                     (send canvas get-top-level-window))]
                  [else #f]))))
	  
	  [define edit-sequence-queue null]
	  [define edit-sequence-ht (make-hash-table)]
	  [define in-local-edit-sequence? #f]
	  [define/public local-edit-sequence? (λ () in-local-edit-sequence?)]
	  [define/public run-after-edit-sequence
	    (case-lambda 
	     [(t) (run-after-edit-sequence t #f)]
	     [(t sym)
	      (unless (and (procedure? t)
			   (= 0 (procedure-arity t)))
		(error 'editor:basic::run-after-edit-sequence
		       "expected procedure of arity zero, got: ~s~n" t))
	      (unless (or (symbol? sym) (not sym))
		(error 'editor:basic::run-after-edit-sequence
		       "expected second argument to be a symbol or #f, got: ~s~n"
		       sym))
	      (if (refresh-delayed?)
		  (if in-local-edit-sequence?
		      (cond
			[(symbol? sym)
			 (hash-table-put! edit-sequence-ht sym t)]
			[else (set! edit-sequence-queue
				    (cons t edit-sequence-queue))])
		      (let ([snip-admin (get-admin)])
			(cond
			  [(not snip-admin)
			   (t)] ;; refresh-delayed? is always #t when there is no admin.
			  [(is-a? snip-admin editor-snip-editor-admin<%>)
			   (send (send (send (send snip-admin get-snip) get-admin) get-editor)
				 run-after-edit-sequence t sym)]
			  [else
			   '(message-box "run-after-edit-sequence error"
                                         (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
                                                 snip-admin))
			   '(t)
                           (void)])))
		  (t))
	      (void)])]
	  [define/public extend-edit-sequence-queue
	    (λ (l ht)
	      (hash-table-for-each ht (λ (k t)
					(hash-table-put! 
					 edit-sequence-ht
					 k t)))
	      (set! edit-sequence-queue (append l edit-sequence-queue)))]
	  (define/augment (on-edit-sequence)
            (set! in-local-edit-sequence? #t)
            (inner (void) on-edit-sequence))
	  (define/augment (after-edit-sequence)
            (set! in-local-edit-sequence? #f)
            (let ([queue edit-sequence-queue]
                  [ht edit-sequence-ht]
                  [find-enclosing-editor
                   (λ (editor)
                     (let ([admin (send editor get-admin)])
                       (cond
                         [(is-a? admin editor-snip-editor-admin<%>)
                          (send (send (send admin get-snip) get-admin) get-editor)]
                         [else #f])))])
              (set! edit-sequence-queue null)
              (set! edit-sequence-ht (make-hash-table))
              (let loop ([editor (find-enclosing-editor this)])
                (cond
                  [(and editor 
                        (is-a? editor basic<%>)
                        (not (send editor local-edit-sequence?)))
                   (loop (find-enclosing-editor editor))]
                  [(and editor
                        (is-a? editor basic<%>))
                   (send editor extend-edit-sequence-queue queue ht)]
                  [else
                   (hash-table-for-each ht (λ (k t) (t)))
                   (for-each (λ (t) (t)) queue)])))
            (inner (void) after-edit-sequence))
	  
	  [define/override on-new-box
	    (λ (type)
	      (cond
		[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
		[else (make-object editor-snip% (make-object pasteboard:basic%))]))]
	  
	  
	  (define/override (get-file d)
            (parameterize ([finder:dialog-parent-parameter
                            (get-top-level-window)])
              (finder:get-file d)))
	  (define/override (put-file d f)
            (parameterize ([finder:dialog-parent-parameter
                            (get-top-level-window)])
              (finder:put-file f d)))
	  
	  
	  (super-instantiate ())))

      (define standard-style-list (new style-list%))
      (define (get-standard-style-list) standard-style-list)
      
      (define default-color-style-name "framework:default-color")
      (define (get-default-color-style-name) default-color-style-name)
      
      (let ([delta (make-object style-delta% 'change-normal)])
        (send delta set-delta 'change-family 'modern)
        (let ([style (send standard-style-list find-named-style "Standard")])
          (if style
              (send style set-delta delta)
              (send standard-style-list new-named-style "Standard"
                    (send standard-style-list find-or-create-style
                          (send standard-style-list find-named-style "Basic")
                          delta)))))
        
      (let ([delta (make-object style-delta%)]
	    [style (send standard-style-list find-named-style default-color-style-name)])
	(if style
	    (send style set-delta delta)
	    (send standard-style-list new-named-style default-color-style-name
		  (send standard-style-list find-or-create-style
			(send standard-style-list find-named-style "Standard")
			delta))))
      
      (define (set-default-font-color color)
        (let* ([scheme-standard (send standard-style-list find-named-style default-color-style-name)]
               [scheme-delta (make-object style-delta%)])
          (send scheme-standard get-delta scheme-delta)
          (send scheme-delta set-delta-foreground color)
          (send scheme-standard set-delta scheme-delta)))
      
      (define (set-font-size size)
        (update-standard-style
         (λ (scheme-delta)
           (send scheme-delta set-size-mult 0)
           (send scheme-delta set-size-add size))))
      
      (define (set-font-name name)
        (update-standard-style
         (λ (scheme-delta)
           (send scheme-delta set-delta-face name)
           (send scheme-delta set-family 'modern))))
      
      (define (set-font-smoothing sym)
        (update-standard-style
         (λ (scheme-delta)
           (send scheme-delta set-smoothing-on sym))))
      
      (define (update-standard-style cng-delta)
        (let* ([scheme-standard (send standard-style-list find-named-style "Standard")]
               [scheme-delta (make-object style-delta%)])
          (send scheme-standard get-delta scheme-delta)
          (cng-delta scheme-delta)
          (send scheme-standard set-delta scheme-delta)))
      
      (define standard-style-list<%>
        (interface (editor<%>)
          ))
      
      (define standard-style-list-mixin
        (mixin (editor<%>) (standard-style-list<%>)
          (super-instantiate ())
          (inherit set-style-list set-load-overwrites-styles)
          (set-style-list standard-style-list)
	  (set-load-overwrites-styles #f)))
          
      (define (set-standard-style-list-pref-callbacks)
        (set-font-size (preferences:get 'framework:standard-style-list:font-size))
        (set-font-name (preferences:get 'framework:standard-style-list:font-name))
        (set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing))
        (preferences:add-callback 'framework:standard-style-list:font-size (λ (p v) (set-font-size v)))
        (preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v)))
        (preferences:add-callback 'framework:standard-style-list:smoothing (λ (p v) (set-font-smoothing v)))
        
        (unless (member (preferences:get 'framework:standard-style-list:font-name) (get-face-list 'mono))
          (preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern))))
      
      ;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void
      (define (set-standard-style-list-delta name delta)
        (let* ([style-list (get-standard-style-list)]
               [style (send style-list find-named-style name)])
          (if style
              (send style set-delta delta)
              (send style-list new-named-style name
                    (send style-list find-or-create-style
                          (send style-list find-named-style "Standard")
                          delta)))
          (void)))
      
      (define -keymap<%> (interface (basic<%>) get-keymaps))
      (define keymap-mixin
	(mixin (basic<%>) (-keymap<%>)
	  [define/public get-keymaps
            (λ ()
              (list (keymap:get-global)))]
	  (inherit set-keymap)

          (super-instantiate ())
          (let ([keymap (make-object keymap:aug-keymap%)])
            (set-keymap keymap)
            (for-each (λ (k) (send keymap chain-to-keymap k #f))
                      (get-keymaps)))))

      (define autowrap<%> (interface (basic<%>)))
      (define autowrap-mixin
	(mixin (basic<%>) (autowrap<%>)
	  (inherit auto-wrap)
          (super-instantiate ())
          (auto-wrap 
           (preferences:get
            'framework:auto-set-wrap?))))
      
      (define file<%> 
        (interface (-keymap<%>)
          get-can-close-parent
          update-frame-filename
          allow-close-with-no-filename?))
      
      (define file-mixin
        (mixin (-keymap<%>) (file<%>)
          (inherit get-filename lock get-style-list 
                   is-modified? set-modified 
                   get-top-level-window)

          (inherit get-canvases get-filename/untitled-name)
          (define/public (update-frame-filename)
            (let* ([filename (get-filename)]
                   [name (if filename
                             (path->string (file-name-from-path (normalize-path filename)))
                             (get-filename/untitled-name))])
              (for-each (λ (canvas)
                          (let ([tlw (send canvas get-top-level-window)])
                            (when (and (is-a? tlw frame:editor<%>)
                                       (eq? this (send tlw get-editor)))
                              (send tlw set-label name))))
                        (get-canvases))))
          
          (define/override set-filename
	    (case-lambda
	     [(name) (set-filename name #f)]
	     [(name temp?)
	      (super set-filename name temp?)
	      (unless temp?
		(update-frame-filename))]))

          (inherit save-file)
          (define/public (allow-close-with-no-filename?) #f)
          (define/augment (can-close?)
            (let* ([user-allowed-or-not-modified
                    (or (not (is-modified?))
                        (and (not (get-filename))
                             (allow-close-with-no-filename?))
                        (case (gui-utils:unsaved-warning
                               (get-filename/untitled-name)
                               (string-constant close-anyway)
                               #t
                               (or (get-top-level-window)
                                   (get-can-close-parent)))
                          [(continue) #t]
                          [(save) (save-file)]
                          [else #f]))])
              (and user-allowed-or-not-modified
                   (inner #t can-close?))))
          
          (define/public (get-can-close-parent) #f)
          
          (define/override (get-keymaps)
            (cons (keymap:get-file) (super get-keymaps)))
          (super-new)))
      
      (define backup-autosave<%>
	(interface (basic<%>)
	  backup?
	  autosave?
	  do-autosave
	  remove-autosave))

      (define backup-autosave-mixin
	(mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>)
	  (inherit is-modified? get-filename save-file)
	  [define auto-saved-name #f]
          [define auto-save-out-of-date? #t]
          [define auto-save-error? #f]
          (define/private (file-old? filename)
            (if (and filename
                     (file-exists? filename))
                (let ([modified-seconds (file-or-directory-modify-seconds filename)]
                      [old-seconds (- (current-seconds) (* 7 24 60 60))])
                  (< modified-seconds old-seconds))
                #t))
          (define/public (backup?) (preferences:get 'framework:backup-files?))
          (define/augment (on-save-file name format)
            (set! auto-save-error? #f)
            (when (and (backup?)
                       (not (eq? format 'copy))
                       (file-exists? name))
              (let ([back-name (path-utils:generate-backup-name name)])
                (when (or (not (file-exists? back-name))
                          (file-old? back-name))
                  (when (file-exists? back-name)
                    (delete-file back-name))
                  (with-handlers ([(λ (x) #t) void])
                    (copy-file name back-name)))))
            (inner (void) on-save-file name format))
          (define/augment (on-close)
            (remove-autosave)
            (set! do-autosave? #f)
            (inner (void) on-close))
          (define/augment (on-change)
            (set! auto-save-out-of-date? #t)
            (inner (void) on-change))
          (define/override (set-modified modified?)
            (when auto-saved-name
              (if modified?
                  (set! auto-save-out-of-date? #t)
                  (remove-autosave)))
            (super set-modified modified?))
          
          [define do-autosave? #t]
	  (define/public (autosave?) do-autosave?)

          (define/public (do-autosave)
            (cond
              [(and (autosave?)
                    (not auto-save-error?)
                    (is-modified?)
                    (or (not auto-saved-name)
                        auto-save-out-of-date?))
               (let* ([orig-name (get-filename)]
                      [old-auto-name auto-saved-name]
                      [auto-name (path-utils:generate-autosave-name orig-name)]
		      [orig-format (and (is-a? this text%)
					(send this get-file-format))])
		 (when (is-a? this text%)
		   (send this set-file-format 'standard))
                 (with-handlers ([exn:fail?
                                  (λ (exn)
                                    (show-autosave-error exn orig-name)
                                    (set! auto-save-error? #t)
				    (when (is-a? this text%)
				      (send this set-file-format orig-format))
                                    #f)])
                   (save-file auto-name 'copy #f)
		   (when (is-a? this text%)
		     (send this set-file-format orig-format))
                   (when old-auto-name
                     (delete-file old-auto-name))
                   (set! auto-saved-name auto-name)
                   (set! auto-save-out-of-date? #f)
                   auto-name))]
              [else auto-saved-name]))

	  ;; show-autosave-error : any (union #f string) -> void
	  ;; opens a message box displaying the exn and the filename
	  ;; to the user.
	  (define/private (show-autosave-error exn orig-name)
	    (message-box 
	     (string-constant warning)
	     (string-append
	      (format (string-constant error-autosaving)
		      (or orig-name (string-constant untitled)))
	      "\n"
	      (string-constant autosaving-turned-off)
	      "\n\n"
	      (if (exn? exn)
		  (format "~a" (exn-message exn))
		  (format "~s" exn)))
	     #f
	     '(caution ok)))
	  
          (define/public (remove-autosave)
            (when auto-saved-name
              (when (file-exists? auto-saved-name)
                (delete-file auto-saved-name))
              (set! auto-saved-name #f)))
	  (super-instantiate ())
          (autosave:register this)))

      (define info<%> (interface (basic<%>)))
      (define info-mixin
	(mixin (basic<%>) (info<%>)
	  (inherit get-top-level-window run-after-edit-sequence)
	  (define callback-running? #f)
          (define/override (lock x)
            (super lock x)
            (run-after-edit-sequence
             (rec send-frame-update-lock-icon
               (λ ()
                 (unless callback-running?
                   (set! callback-running? #t)
                   (queue-callback
                    (λ ()
                      (let ([frame (get-top-level-window)])
                        (when (is-a? frame frame:info<%>)
                          (send frame lock-status-changed)))
                      (set! callback-running? #f))
                    #f))))
             'framework:update-lock-icon))
          (super-instantiate ()))))))