#lang racket/base

(require racket/file
         "test-suite-utils.rkt")

(module test racket/base)

(define dummy-frame-title "dummy to avoid quitting")
(queue-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))

(define (test-creation frame% class name)
  (test
   name
   (lambda (x) 
     (equal? x (list dummy-frame-title))) ;; ensure no frames left
   (lambda ()
     (let ([label
            (queue-sexp-to-mred
             `(let ([f (new (class ,frame%
                              (define/override (get-editor%) ,class)
                              (super-new)))])
                (send (send f get-editor) set-max-undo-history 10)
                (send f show #t)
                (send f get-label)))])
       (wait-for-frame label)
       (send-sexp-to-mred `(test:keystroke #\a))
       (wait-for #:queue? #t `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
       (queue-sexp-to-mred
        `(begin 
           ;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
           (send (send (get-top-level-focus-window) get-editor) undo) 
           (send (send (get-top-level-focus-window) get-editor) undo)
           
           (send (send (get-top-level-focus-window) get-editor) lock #t)
           (send (send (get-top-level-focus-window) get-editor) lock #f)
           (send (get-top-level-focus-window) close)))
       (queue-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))

#|
  (test-creation 'frame:text%
                 '(text:basic-mixin (editor:basic-mixin text%))
                 'text:basic-mixin-creation)
  (test-creation 'frame:text%
                 'text:basic%
                 'text:basic-creation)
  |#
(test-creation 'frame:text%
               '(editor:file-mixin text:keymap%)
               'editor:file-mixin-creation)

(test-creation 'frame:text%
               'text:file%
               'text:file-creation)
(test-creation 'frame:text%
               '(text:clever-file-format-mixin text:file%)
               'text:clever-file-format-mixin-creation)
(test-creation 'frame:text%
               'text:clever-file-format%
               'text:clever-file-format-creation)
(test-creation 'frame:text%
               '(editor:backup-autosave-mixin text:clever-file-format%)
               'editor:backup-autosave-mixin-creation)
(test-creation 'frame:text%
               'text:backup-autosave%
               'text:backup-autosave-creation)
(test-creation 'frame:text%
               '(text:searching-mixin text:backup-autosave%)
               'text:searching-mixin-creation)
(test-creation 'frame:text%
               'text:searching%
               'text:searching-creation)
(test-creation '(frame:searchable-mixin frame:text%)
               '(text:info-mixin (editor:info-mixin text:searching%))
               'text:info-mixin-creation)
(test-creation '(frame:searchable-mixin frame:text%)
               'text:info%
               'text:info-creation)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing highlight-range method
;;



(test
 'highlight-range1
 (lambda (x) (equal? x 1))
 (λ ()
   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
       (length (send t get-highlighted-ranges))))))

(test
 'highlight-range2
 (lambda (x) (equal? x 0))
 (λ ()
   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       ((send t highlight-range 1 2 "red"))
       (length (send t get-highlighted-ranges))))))


(test
 'highlight-range3
 (lambda (x) (equal? x 0))
 (λ ()
   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
       (send t unhighlight-range 1 2 "red")
       (length (send t get-highlighted-ranges))))))


(test
 'highlight-range4
 (lambda (x) (equal? x 1))
 (λ ()
   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
       (send t highlight-range 1 2 "red")
       (send t unhighlight-range 1 2 "red")
       (length (send t get-highlighted-ranges))))))



(test
 'highlight-range5
 (lambda (x) (equal? x 0))
 (λ ()
   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
       (send t highlight-range 1 2 "red")
       (send t unhighlight-range 1 2 "red")
       (send t unhighlight-range 1 2 "red")
       (length (send t get-highlighted-ranges))))))

(let ([tmp-file (path->string (make-temporary-file "fwtesttmp~a"))])
  (test
   'highlight-range/revert
   (lambda (x)
     (delete-file tmp-file)
     (equal? x 0))
   (λ ()
     (queue-sexp-to-mred
      `(let ([t (new text:basic%)])
         (send t insert "abc")
         (send t save-file ,tmp-file)
         (send t highlight-range 0 3 "red")
         (call-with-output-file ,tmp-file
           (lambda (port) (display "x\n" port))
           #:exists 'truncate)
         (send t load-file)
         (length (send t get-highlighted-ranges)))))))

(test
 'highlight-range-delegate-1
 (lambda (x) (equal? x 0))
 (λ ()
   (queue-sexp-to-mred
    `(let ([t (new text:delegate%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
       (send t unhighlight-range 1 2 "red")
       (length (send t get-highlighted-ranges))))))

(test
 'highlight-range-delegate-1
 (lambda (x) (equal? x 0))
 (λ ()
   (queue-sexp-to-mred
    `(let ([t (new text:delegate%)])
       (send t set-delegate (new text:basic%))
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
       (send t unhighlight-range 1 2 "red")
       (length (send t get-highlighted-ranges))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  testing get-pos/text method
;;

(test
  'get-pos/text-1
  (λ (x) x)
  (λ ()
    (queue-sexp-to-mred
      '(let* ([f (new frame% [label "Test frame"])]
              [t (new text:basic%)]
              [c (new editor-canvas% [parent f] [editor t])]
              [snip (make-object string-snip% "Test string")])
          (send t insert snip)
          (define-values (x-box y-box) (values (box 0) (box 0)))
          (send t get-snip-location snip x-box y-box)
          (send t local-to-global x-box y-box)
          (define event (new mouse-event% [event-type 'motion]
                                          [x (add1 (unbox x-box))]
                                          [y (add1 (unbox y-box))]))
          (let-values ([(pos edit) (send t get-pos/text event)])
            (and (real? (car p)) (is-a? (cdr p) text%)))))))

(test
  'get-pos/text-2
  (λ (x) x)
  (λ ()
    (queue-sexp-to-mred
      '(let* ([f (new frame% [label "Test frame"])]
              [t (new text:basic%)]
              [c (new editor-canvas% [parent f] [editor t])]
              [snip (make-object string-snip% "Test string")])
          (send t insert snip)
          (define-values (x-box y-box) (values (box 0) (box 0)))
          (send t get-snip-location snip x-box y-box)
          (send t local-to-global x-box y-box)
          (define event (new mouse-event% [event-type 'motion]
                                          [x (+ 9999 (unbox x-box))]
                                          [y (+ 9999 (unbox y-box))]))
          (let-values ([(pos edit) (send t get-pos/text event)])
            (and (false? pos) (false? edit)))))))

(test
  'get-pos/text-3
  (λ (x) x)
  (λ ()
    (queue-sexp-to-mred
      '(let* ([f (new frame% [label "Test frame"])]
              [t (new text:basic%)]
              [c (new editor-canvas% [parent f] [editor t])]
              [p (new pasteboard%)]
              [s-snip (make-object string-snip% "Test string")]
              [e-snip (new editor-snip% [editor p])])
          (send p insert s-snip)
          (send t insert e-snip)
          (define-values (x-box y-box) (values (box 0) (box 0)))
          (send t get-snip-location e-snip x-box y-box)
          (send t local-to-global x-box y-box)
          (define event (new mouse-event% [event-type 'motion]
                                          [x (add1 (unbox x-box))]
                                          [y (add1 (unbox y-box))]))
          (let-values ([(pos edit) (send t get-pos/text event)])
            (and (false? pos) (is-a? edit pasteboard%)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  print-to-dc
;;

(test
 'print-to-dc
 (λ (x) (equal? x 'no-error))
 (λ ()
   (queue-sexp-to-mred
    '(let* ([t (new text:basic%)]
            [bmp (make-object bitmap% 100 40)]
            [dc (new bitmap-dc% (bitmap bmp))])
       (send t insert "Hello world")
       (send dc clear)
       (send t print-to-dc dc 1)
       'no-error))))


(test
 'print-to-dc2
 (λ (x) (equal? x 'no-error))
 (λ ()
   (queue-sexp-to-mred
    `(let* ([f (new frame% [label ""])]
            [t (new text:basic%)]
            [ec (new editor-canvas% [parent f] [editor t])]
            [bmp (make-object bitmap% 100 40)]
            [dc (new bitmap-dc% (bitmap bmp))])
       (send t insert "Hello world")
       (send t highlight-range 2 5 "orange")
       (send f reflow-container)
       (send dc clear)
       (send t print-to-dc dc 1)
       'no-error))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  text:ports
;;

;; there is an internal buffer of this size, so writes that are larger and smaller are interesting
(define buffer-size 4096)

(let ()
  (define big-str
    (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a))))))
  (define non-ascii-str "λαβ一二三四五")
  (define (do/separate-thread str mtd)
    (queue-sexp-to-mred
     `(let* ([t (new (text:ports-mixin text:wide-snip%))]
             [op (send t ,mtd)]
             [exn #f])
        (yield
         (thread
          (λ () 
            (with-handlers ((exn:fail? (λ (x) (set! exn x))))
              (display ,str op)
              (flush-output op)))))
        (when exn (raise exn))
        (send t get-text 0 (send t last-position)))))
  
  (test 
   'text:ports%.1
   (λ (x) (equal? x "abc"))
   (λ () (do/separate-thread "abc" 'get-out-port)))
  
  (test 
   'text:ports%.2
   (λ (x) (equal? x big-str))
   (λ () (do/separate-thread big-str 'get-out-port)))
  
  (test 
   'text:ports%.3
   (λ (x) (equal? x non-ascii-str))
   (λ () (do/separate-thread non-ascii-str 'get-out-port)))
  
  (test 
   'text:ports%.4
   (λ (x) (equal? x "abc"))
   (λ () (do/separate-thread "abc" 'get-err-port)))
  
  (test 
   'text:ports%.5
   (λ (x) (equal? x big-str))
   (λ () (do/separate-thread big-str 'get-err-port)))
  
  (test 
   'text:ports%.6
   (λ (x) (equal? x non-ascii-str))
   (λ () (do/separate-thread non-ascii-str 'get-err-port)))
  
  
  (test 
   'text:ports%.7
   (λ (x) (equal? x "abc"))
   (λ () (do/separate-thread "abc" 'get-value-port)))
  
  (test 
   'text:ports%.8
   (λ (x) (equal? x big-str))
   (λ () (do/separate-thread big-str 'get-value-port)))
  
  (test 
   'text:ports%.9
   (λ (x) (equal? x non-ascii-str))
   (λ () (do/separate-thread non-ascii-str 'get-value-port)))
  
  ;; display the big string, one char at a time
  (test
   'text:ports%.10
   (λ (x) (equal? x big-str))
   (λ () 
     (queue-sexp-to-mred
      `(let* ([t (new (text:ports-mixin text:wide-snip%))]
              [op (send t get-out-port)]
              [big-str ,big-str]
              [exn #f])
         (yield
          (thread
           (λ () 
             (with-handlers ((exn:fail? (λ (x) (set! exn x))))
               (let loop ([i 0])
                 (when (< i (string-length big-str))
                   (display (string-ref big-str i) op)
                   (loop (+ i 1))))
               (flush-output op)))))
         (when exn (raise exn))
         (send t get-text 0 (send t last-position))))))
  
  (let ([s "五"])
    (test
     'text:ports%.partial-encoding
     (λ (x) (equal? x s))
     (λ ()
       (define bts (string->bytes/utf-8 s))
       (queue-sexp-to-mred
        `(let ()
           (define t (new (text:ports-mixin text:wide-snip%)))
           (define p (send t get-out-port))
           (void (write-bytes (bytes ,(bytes-ref bts 0)) p))
           (flush-output p)
           (void (write-bytes ,(subbytes bts 1 (bytes-length bts)) p))
           (flush-output p)
           (send t get-text))))))
  
  (let ([b (bytes 195 195 (char->integer #\a))])
    (test
     'text:ports%.broken-encoding
     (λ (x) 
       (define c (bytes-open-converter "UTF-8-permissive" "UTF-8"))
       (define-values (result-bytes src-read-amt termination) (bytes-convert c b))
       (equal? x (bytes->string/utf-8 result-bytes)))
     (λ ()
       (queue-sexp-to-mred
        `(let ()
           (define t (new (text:ports-mixin text:wide-snip%)))
           (define p (send t get-out-port))
           (yield
            (thread
             (λ ()
               (write-bytes ,b p)
               (flush-output p))))
           (send t get-text))))))

     
  ;; the next tests test the interaction when the current
  ;; thread is the same as the handler thread of the eventspace
  ;; where the text was created
  
  (test 
   'text:ports%.thd1
   (λ (x) (equal? x "abc"))
   (λ ()
     (queue-sexp-to-mred
      `(let* ([t (new (text:ports-mixin text:wide-snip%))]
              [op (send t get-out-port)]
              [exn #f])
         (display "abc" op)
         (flush-output op)
         (send t get-text 0 (send t last-position))))))
  
  (test 
   'text:ports%.thd2
   (λ (x) (equal? x big-str))
   (λ ()
     (queue-sexp-to-mred
      `(let* ([t (new (text:ports-mixin text:wide-snip%))]
              [op (send t get-out-port)])
         (display ,big-str op)
         (flush-output op)
         (send t get-text 0 (send t last-position))))))
  
  (test 
   'text:ports%.thd3
   (λ (x) (equal? x non-ascii-str))
   (λ ()
     (queue-sexp-to-mred
      `(let* ([t (new (text:ports-mixin text:wide-snip%))]
              [op (send t get-out-port)])
         (display ,non-ascii-str op)
         (flush-output op)
         (send t get-text 0 (send t last-position))))))
  
  (test 
   'text:ports%.thd4
   (λ (x) (equal? x non-ascii-str))
   (λ ()
     (queue-sexp-to-mred
      `(let* ([t (new (text:ports-mixin text:wide-snip%))]
              [op (send t get-out-port)])
         (display ,non-ascii-str op)
         (flush-output op)
         (send t get-text 0 (send t last-position))))))


  ;; This test sends a lot of flushes from a separate thread and,
  ;; while doing that, sends a `clear-output-ports` from the
  ;; eventspace main thread where the text was created. The goal
  ;; is to make sure there is no deadlock for this interaction.
  (test
   'text:ports%.flush-and-clear-output-ports-interaction
   (λ (x)
     ;; we know we're going to get all 'a's, but some of
     ;; the output could be discarded by `clear-output-ports`
     (and (regexp-match #rx"^a*$" x)
          (<= 100 (string-length x) 200)))
   (λ ()
     (queue-sexp-to-mred
      `(let ()
         (define es (make-eventspace))
         (define-values (text port)
           (let ()
             (define c (make-channel))
             (parameterize ([current-eventspace es])
               (queue-callback
                (λ ()
                  (define t
                    (new (text:ports-mixin
                          (text:wide-snip-mixin
                           text:basic%))))
                  (channel-put c t)
                  (channel-put c (send t get-out-port)))))
             (values (channel-get c)
                     (channel-get c))))
         (define clear-output-go (make-semaphore 0))
         (define clear-output-done (make-semaphore 0))
         (void
          (thread
           (λ ()
             (semaphore-wait clear-output-go)
             (parameterize ([current-eventspace es])
               (queue-callback
                (λ ()
                  (send text clear-output-ports)
                  (semaphore-post clear-output-done)))))))
         (for ([x (in-range 100)])
           (display #\a port)
           (flush-output port))
         (semaphore-post clear-output-go)
         (for ([x (in-range 100)])
           (display #\a port)
           (flush-output port))
         (semaphore-wait clear-output-done)
         (send text get-text))))))