
(load-relative "loadtest.rktl")

(require racket/gui/base)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                            Editor Tests                                    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;; File and port save/load tests

(define (run-save/load-tests editor% insert reset?)
  (when reset?
    (map (lambda (f)
	   (when (file-exists? f) (delete-file f)))
	 '("tmp99" "tmp98" "tmp97" "tmp96" "tmp95")))
  (let* ([mode #f]
	 [editor+% (class editor%
		     (define/augment (on-load-file path -mode)
		       (set! mode -mode))
		     (define/augment (on-save-file path -mode)
		       (set! mode -mode))
		     (super-new))]
	 [e (make-object editor+%)]
	 [ck-text (lambda (path)
		    (when (eq? editor% text%)
		      (st 'text e get-file-format)
		      (when path
			(test "Hello" 'content (with-input-from-file path
						 (lambda ()
						   (read-string 100)))))))]
	 [ck-binary (lambda (path)
		      (when (eq? editor% text%)
			(st 'standard e get-file-format))
		      (when path
			(test #"#reader(lib\"read.ss\"\"wxme\")WXME" 'content (with-input-from-file path
                                                                                (lambda ()
                                                                                  (read-bytes 31))))))]
	 [ck-mode (lambda (-mode)
		    (test (if (eq? editor% pasteboard%) 
			      (if (eq? -mode 'copy)
				  'copy
				  'standard) 
			      -mode) 
			  'mode mode))])
    (insert e "Hello")
    (st #t e is-modified?)
    (st #f e get-filename)
    (when (eq? editor% text%)
      (st 'standard e get-file-format))
    (st #t e save-file "tmp99" 'text)
    (ck-mode 'text)
    (st (string->path "tmp99") e get-filename)
    (st #f e is-modified?)
    (ck-text "tmp99")
    (insert e "Ack")
    (st #t e is-modified?)
    (st #t e load-file "tmp99" 'guess)
    (ck-mode 'guess)
    (ck-text #f)
    (st #f e is-modified?)
    (st "Hello" e get-flattened-text)
    (let ([now (file-or-directory-modify-seconds "tmp99")])
      (st #t e save-file "tmp99" 'same)
      (ck-text "tmp99")
      (st (string->path "tmp99") e get-filename)
      (let ([later (file-or-directory-modify-seconds "tmp99")])
	(test #t 'file-date (now . <= . later))
	(st #t e save-file "tmp98" 'standard)
	(test #f 'file-date (later . < . (file-or-directory-modify-seconds "tmp99")))
	(ck-binary "tmp98")
	(st #t e load-file "tmp98" 'guess)
	(ck-mode 'guess)
	(ck-binary #f)
	(st #t e load-file "tmp98" 'text)
	(ck-mode 'text)
	(ck-text #f)
	(when (eq? editor% text%)
          (st "#reader(lib\"read.ss\"\"wxme\")WXME"  e get-text 0 31))
	(st #t e load-file "tmp98" 'same)
	(ck-mode 'same)
	(ck-text #f)
        (when (eq? editor% text%)
          (st "#reader(lib\"read.ss\"\"wxme\")WXME"  e get-text 0 31))
	(st #t e load-file "tmp98" 'guess)
	(ck-mode 'guess)
	(ck-binary #f)
	(st "Hello" e get-flattened-text)))
    (let ([target "tmp97"])
      ;; Check [non-]temporary file names
      (set! e (make-object (class editor+%
			     (define/override (put-file file dir)
			       (string->path target))
			     (super-new))))
      (insert e "Howdy")
      (st #t e is-modified?)
      (set! mode #f)
      (st #t e save-file #f 'copy)
      (ck-mode 'copy)
      (set! target "tmp95")
      (st #t e is-modified?)
      (ck-binary "tmp97")
      (stv e set-filename "tmp96")
      (st #t e save-file #f)
      (st #f e is-modified?)
      (st (string->path "tmp96") e get-filename)
      (ck-binary "tmp96")
      (stv e set-filename "tmp96" #t)
      (st #t e save-file #f)
      (ck-mode 'same)
      (st (string->path "tmp95") e get-filename)
      (stv e set-filename "tmp96" #t)
      (st #t e save-file "")
      (st (string->path "tmp95") e get-filename)
      (ck-binary "tmp95")
      (st "Howdy" e get-flattened-text)
      (when (eq? editor% text%)
	(stv e set-position 100))
      (st #t e insert-file "tmp98")
      (st "HowdyHello" e get-flattened-text)
      (st #t e insert-file "tmp99")
      (st "HowdyHelloHello" e get-flattened-text)
      (st (string->path "tmp95") e get-filename))))
    
(define text-insert (lambda (e t) (send e insert t)))
(define pb-insert (lambda (e t) (send e insert (make-object string-snip% t))))

(map (lambda (reset?)
       (run-save/load-tests text% text-insert reset?)
       (run-save/load-tests pasteboard% pb-insert reset?))
     '(#t #f))

;; Test DrRacket-style format change in `on-save':
(define (run-on-save-tests editor% insert)
  (let* ([editor+% (if (eq? editor% text%)
		       (class editor%
			 (inherit set-file-format)
			 (define/augment (on-save-file path -mode)
			   (set-file-format 'standard))
			 (super-new))
		       editor%)]
	 [e (make-object editor+%)])
    (insert e "Hello")
    (st #t e is-modified?)
    (st #f e get-filename)
    (when (eq? editor% text%)
      (stv e set-file-format 'text)
      (st 'text e get-file-format))
    (st #t e save-file "tmp99" 'same)
    (when (eq? editor% text%)
      (st 'standard e get-file-format))
    (send e load-file "tmp99" 'guess)
    (st "Hello" e get-flattened-text)))
(run-on-save-tests text% text-insert)
(run-on-save-tests pasteboard% pb-insert)

;;;;;; Undo tests

(define e (make-object text%))
(send e set-max-undo-history 1024)

(stv e insert "Hello")
(st #t e is-modified?)
(stv e undo)
(st #f e is-modified?)
(stv e redo)
(st #t e is-modified?)
(stv e set-modified #f)
(st #f e is-modified?)
(stv e undo)
(st #t e is-modified?)
(stv e redo)
(st #f e is-modified?)
(stv e undo)
(st #t e is-modified?)
(stv e redo)
(st #f e is-modified?)
(stv e undo)
(st "" e get-text)
(stv e set-modified #f)
(st #f e is-modified?)
(stv e redo) ; somehow cancel's redo action to set modified to #f...
(st #t e is-modified?)
(st "Hello" e get-text)
(define undone? #f)
(stv e add-undo (letrec ([f (lambda ()
			      (set! undone? #t)
			      (send e add-undo f) ; reinstall self!
			      #f)])
		  f))
(stv e undo)
(st "Hello" e get-text)
(test #t 'undone? undone?)
(stv e undo)
(st "" e get-text)
(set! undone? #f)
(stv e redo)
(st "Hello" e get-text)
(test #f 'undone? undone?)
(stv e redo)
(st "Hello" e get-text)
(test #t 'undone? undone?)
(set! undone? #f)
(stv e redo)
(st "Hello" e get-text)
(test #f 'undone? undone?)
(stv e insert "x")
(st "Hellox" e get-text)
(stv e add-undo (lambda ()
		  (set! undone? #t)
		  #t)) ; do next one, too
(stv e undo)
(test #t 'undone? undone?)
(st "Hello" e get-text)

;; Editor ports

(let ([e (make-object text%)]
      [res-mode? #f])
  (stv e insert "hello")
  (let ([p (open-input-text-editor e)])
    (test 'hello 'read (read p))
    (test eof 'read (read p)))
  (stv e insert " there")
  (let ([p (open-input-text-editor e)])
    (test 'hello 'read (read p))
    (test 'there 'read (read p))
    (test eof 'read (read p)))
  (stv e insert (make-object
		 (class* snip% 
		   (readable-snip<%>)
		   (define/public (read-special src line col pos)
		     (if res-mode?
			 'res
			 (error 'ack)))
		   (super-new))))
  (let ([p (open-input-text-editor e)])
    (port-count-lines! p)
    (test '(1 0 1) 'pos (call-with-values (lambda () (port-next-location p)) list))
    (test 'hello 'read (read p))
    (test '(1 5 6) 'pos (call-with-values (lambda () (port-next-location p)) list))
    (test 'there 'read (read p))
    (test '(1 11 12) 'pos (call-with-values (lambda () (port-next-location p)) list))
    (test 'got-ack 'read (with-handlers ([exn:fail? (lambda (x)
						      'got-ack)])
			   (read p)))
    (test '(1 12 13) 'pos (call-with-values (lambda () (port-next-location p)) list))
    (test eof 'read (read p)))
  (set! res-mode? #t)
  (let ([p (open-input-text-editor e)])
    (port-count-lines! p)
    (test 'hello 'read (read p))
    (test 'there 'read (read p))
    (test 'res 'read (read p))
    (test '(1 12 13) 'pos (call-with-values (lambda () (port-next-location p)) list))
    (test eof 'read (read p)))
  (stv e insert (make-object image-snip% (build-path
					  (collection-path "icons") 
					  "plt.gif")))
  (let ([p (open-input-text-editor e)])
    (test 'hello 'read (read p))
    (test 'there 'read (read p))
    (test 'res 'read (read p))
    (test #t 'read (is-a? (read p) image-snip%)))
  
  
  (let ()
    (define t (new text%))
    (send t insert (make-string 5000 #\a))
    (define p (open-input-text-editor t #:lock-while-reading? #t))
    (define locked-first (send t is-locked?))
    (void (read p))  ;; read the (big) symbol
    (void (read p))  ;; read eof
    (define locked-last (send t is-locked?))
    (test #t 'lock-while-reading?1 (and locked-first (not locked-last))))
  
  (let ()
    (define t (new text%))
    (send t insert (make-string 5000 #\a))
    (send t insert (make-object image-snip%))
    (define p (open-input-text-editor t #:lock-while-reading? #t))
    (define locked-first (send t is-locked?))
    (void (read p))  ;; read the (big) symbol
    (void (read p))  ;; read the image
    (void (read p))  ;; read eof
    (define locked-last (send t is-locked?))
    (test #t 'lock-while-reading?2 
          (and locked-first
               (not locked-last)))))

(let ()
  (define x (new text%))
  (define s (make-object image-snip% "no-such-image.jpg" 
			 'unknown #f #f))
  (define t (make-object image-snip% "no-such-image.jpg" 
			 'unknown #f #f))
  (send x insert s 0 'same #t)
  (send x insert t 1 'same #t)
  (send x insert "1" 2 'same #t)
  
  (let ([i (open-input-text-editor x 0 'end (lambda (x) (eq? x s)))])
    (test #t 'peek-s (peek-byte-or-special i 0))
    (test #t 'read-s (read-byte-or-special i))
    (test #f 'peek-t (peek-byte-or-special i 0))
    (test 49 'read-1 (peek-byte-or-special i 1))))

(let ()
  (define t (new text%))
  (send t insert "aa\nbb\ncc\ndd\nee\nff\n")
  (send t insert (make-object image-snip%
                   (collection-file-path "recycle.png" "icons")))
  
  (define p (open-input-text-editor t))
  
  (define rev-at-start (send t get-revision-number))
  (define line1 (read-line p))
  
  (define sl (send t get-style-list))
  (define d (make-object style-delta% 'change-bold))
  (define s (send sl find-or-create-style (send sl basic-style) d))
  (send t change-style s 6 7)
  
  (define rev-after-cs (send t get-revision-number))
  (define line2 (read-line p))
  
  (test #t 'revision-changed (> rev-after-cs rev-at-start))
  (test "aa" 'revision-changed-line1 line1)
  (test "bb" 'revision-changed-line1 line2))

(let ()
  (define t (new text%))
  (send t insert "abcd\n")
  (send t insert (make-object image-snip%
                   (collection-file-path "recycle.png" "icons")))
  
  (define (count-snips)
    (let loop ([s (send t find-first-snip)])
      (cond
        [s (+ 1 (loop (send s next)))]
        [else 0])))
  
  (send t split-snip 1)
  (define before-snip-count (count-snips))
  (define rev-at-start (send t get-revision-number))
  
  (define p (open-input-text-editor t))
  
  (define char1 (read-char p))
  
  (define s (send (send t get-style-list) basic-style))
  (send t change-style s 0 4)
  (define after-snip-count (count-snips))
  (define rev-after-cs (send t get-revision-number))
  
  (define chars (string (read-char p) (read-char p) (read-char p)))
  
  (test 4     'snips-joined1 before-snip-count)
  (test 3     'snips-joined2 after-snip-count)
  (test #t     'snips-joined3 (> rev-after-cs rev-at-start))
  (test #\a    'snips-joined4 char1)
  (test "bcd" 'snips-joined5 chars))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                            Snips and Streams                               ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (mk-number-snip-class% term?)
  (class snip-class%
    (define/override (read f)
      (let* ([number-str (if term?
			     (send f get-bytes)
			     (send f get-unterminated-bytes))]
             [number (string->number (bytes->string/utf-8 number-str))]
             [decimal-prefix (bytes->string/utf-8 (if term?
						      (send f get-bytes)
						      (send f get-unterminated-bytes)))]
             [snip
              (instantiate number-snip% ()
                [number number]
                [decimal-prefix decimal-prefix])])
        snip))
    (super-instantiate ())))


(define snip-class (make-object (mk-number-snip-class% #t)))
(send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
(send (get-the-snip-class-list) add snip-class)

(define snip-class2 (make-object (mk-number-snip-class% #f)))
(send snip-class2 set-classname (format "~s" `(lib "number-snip-two.ss" "drscheme" "private")))
(send (get-the-snip-class-list) add snip-class2)

(define (mk-number-snip% snip-class term?)
  (define self%
    (class snip%
      (init-field number)
      (define/public (get-number) number)
      (define/public (get-prefix) decimal-prefix)
      (init-field [decimal-prefix ""])
      (define/override (write f)
	(let ([num (string->bytes/utf-8 (number->string number))]
	      [pfx (string->bytes/utf-8 decimal-prefix)])
	  (if term?
	      (begin
		(send f put num)
		(send f put pfx))
	      (begin
		(unless (eq? 'ok
			     (with-handlers ([exn:fail? (lambda (x) 'ok)])
			       (send f put 5 #"123")
			       'not-ok))
		  (error "too-long write should have failed"))
		(send f put (bytes-length num) num)
		(send f put (bytes-length pfx) pfx)))))
      (define/override (copy)
	(instantiate self% ()
		     [number number]
		     [decimal-prefix decimal-prefix]))
      (inherit get-style)
      (super-instantiate ())
      (inherit set-snipclass set-flags get-flags)
      (set-snipclass snip-class)))
  self%)

(define number-snip% (mk-number-snip% snip-class #t))
(define number-snip2% (mk-number-snip% snip-class2 #f))

(define (snip-test term?)
  (define t (new text%))
  (define t2 (new text%))
  (send t insert (new (if term? number-snip% number-snip2%)
		      [number 1/2]))
  (send t set-position 0 1)
  (send t copy)
  ;; Under X, force snip to be marshalled:
  (let ([s (send the-clipboard get-clipboard-data "WXME" 0)])
    (send the-clipboard set-clipboard-client
	  (make-object (class clipboard-client%
			 (define/override (get-data fmt)
			   (and (string=? fmt "WXME")
				s))
			 (inherit add-type)
			 (super-new)
			 (add-type "WXME")))
	  0))
  (send t2 paste)
  (let ([s (send t2 find-first-snip)])
    (st 1/2 s get-number)
    (st "" s get-prefix)))

(snip-test #t)
(snip-test #f)

(let ()
  (define orig-snip (make-object string-snip% "hello"))
  
  (define out (make-object editor-stream-out-bytes-base%))
  (define out-stream (make-object editor-stream-out% out))
  
  (define _ (send orig-snip write out-stream))
  
  (define in (make-object editor-stream-in-bytes-base% (send out get-bytes)))
  (define in-stream (make-object editor-stream-in% in))
  
  (define new-snip
    (send (send (get-the-snip-class-list) 
		find 
		(send (send (new string-snip%) get-snipclass) get-classname))
	  read in-stream))
  
  (st "hello" new-snip get-text 0 10))

;; ----------------------------------------
;; Check CRLF conversion

(let ([crlf-s (apply
	       string-append
	       (let loop ([n 100])
		 (if (zero? n)
		     null
		     (cons (make-string (random 40) #\a)
			   (cons "\r\n"
				 (loop (sub1 n)))))))]
      [e (new text%)])
  (let ([lf-s (regexp-replace* #rx"\r\n" crlf-s "\n")]
	[lflf-s (regexp-replace* #rx"\r\n" crlf-s "\n\n")])
    (st "" e get-text 0 'eof)
    (send e insert-port (open-input-string crlf-s))
    (st lf-s e get-text 0 'eof)
    (send e erase)
    (send e insert crlf-s)
    (st lflf-s e get-text 0 'eof)))

;; ----------------------------------------
;; Check lines and paras without display, but with a max width

(define t (new text%))
(send t insert "abc\ndef\nghi\n")
(send t set-max-width 955)
(st 0 t line-start-position 0)
(st 4 t line-start-position 1)
(st 8 t line-start-position 2)
(st 0 t paragraph-start-position 0)
(st 4 t paragraph-start-position 1)
(st 8 t paragraph-start-position 2)
(st 3 t paragraph-end-position 0)
(st 7 t paragraph-end-position 1)
(st 11 t paragraph-end-position 2)
(st 0 t paragraph-start-line 0)
(st 1 t paragraph-start-line 1)
(st 2 t paragraph-start-line 2)
(st 0 t line-paragraph 0)
(st 1 t line-paragraph 1)
(st 2 t line-paragraph 2)
(st 0 t position-paragraph 0)
(st 0 t position-paragraph 3)
(st 1 t position-paragraph 4)
(st 1 t position-paragraph 7)
(st 2 t position-paragraph 8)
(st 2 t position-paragraph 11)

;; ----------------------------------------

;; More undo tests, checking mainly that internal undo array grows
;;  correctly

(define (test-undos local-undo?)
  
  (define e (new text%))

  (send e insert (make-string 1024 #\x))

  (send e set-max-undo-history 10240)
  (send e set-position 0)

  (let loop ([n 1024])
    (unless (zero? n)
      (send e set-position (add1 (send e get-start-position)))
      (send e delete)
      (send e insert #\y)
      (when local-undo?
	(send e undo)
	(send e redo))
      (loop (sub1 n))))

  (st (make-string 1024 #\y) e get-text 0 'eof)
  
  (let loop ([n 1023])
    (unless (zero? n)
      (send e undo)
      (send e undo)
      (loop (sub1 n))))

  (st (string-append "y" (make-string 1023 #\x) )
      e get-text 0 'eof))

(test-undos #f)
(test-undos #t)

;; ----------------------------------------

(let ([pb (new pasteboard%)]
      [es (new editor-snip%)])
  (send pb insert es)
  (st es pb find-first-snip)
  (send pb remove es)
  (st #f es is-owned?)
  (st #f pb find-first-snip)
  (send pb insert es)
  (st es pb find-first-snip)
  (st #t es is-owned?))

;; ----------------------------------------
;; edit-sequences and undo

(let ([t (new text%)])
  (send t set-max-undo-history 100)
  (send t begin-edit-sequence)
  (send t begin-edit-sequence)
  (send t insert "abcd\n")
  (send t set-modified #f)
  (send t end-edit-sequence)
  (send t delete 0 1)
  (send t end-edit-sequence)
  (send t undo)
  (st "" t get-text))
  
(let ([t (new text%)])
  (send t set-max-undo-history 100)
  (send t begin-edit-sequence)
  (send t begin-edit-sequence)
  (send t insert "abcd\n")
  (send t end-edit-sequence)
  (send t set-position 0 1)
  (send t delete)
  (send t set-position 0 1)
  (send t delete)
  (send t end-edit-sequence)
  (send t undo)
  (st "" t get-text))

;; ----------------------------------------
;; undo and clickbacks

(let ([t (new text%)])
  (send t set-max-undo-history 100)
  (send t insert "abcdef")
  (send t set-clickback 1 3 void)
  (send t delete 0 5)
  (send t undo))

;; ----------------------------------------
;; notification callbacks, weak links, and chaperones:

(let ()
  (define id 0)
  (define count 0)
  (define count2 0)

  (define sl (new style-list%))

  (define N 100)

  (define cbs
    (for/list ([i (in-range N)])
      (define cb (lambda (x) (set! id i) (set! count (add1 count))))
      ;; procedure retained:
      (void (send sl notify-on-change (chaperone-procedure cb (lambda (v) v))))
      ;; procedure not retained:
      (void (send sl notify-on-change (lambda (x) (set! id i) (set! count2 (add1 count2)))))
      cb))

  (define (try name)
    (send sl new-named-style name (send sl find-named-style "Basic")))

  (try "X")
  (set! count 0)
  (set! count2 0)

  (collect-garbage)
  (try "Y") ;; expect 2 callbacks per notifier

  (define v #f)
  (set! v cbs) ;; forces retention of `cbs'
  (unless (= (length v) N) (error "test is broken"))

  (unless (= count (* 2 N))
    (error 'notifications "too weak? ~e" count))
  (unless (<= 0 count2 (/ N 2))
    (error 'notifications "not weak enough? ~e" count2)))

;; ----------------------------------------
;; make sure splitting a large string snip works:

(void
 (send (make-object string-snip% (make-string 100000 #\a))
       split
       50000
       (box #f)
       (box #f)))

;; ----------------------------------------
;; No #<unsafe-undefined> checks on certain class instances

(test #f 'undef-snip (impersonator? (new snip%)))
(test #f 'undef-string-snip% (impersonator? (new string-snip%)))
(test #f 'undef-tab-snip% (impersonator? (new tab-snip%)))
(test #f 'undef-image-snip% (impersonator? (new image-snip%)))
(test #f 'undef-style-delta% (impersonator? (new style-delta%)))
(test #f 'undef-style<%> (impersonator? (send (new style-list%) basic-style)))

;; ----------------------------------------

(report-errs)

