#lang racket/base

(require racket/contract
         racket/unit
         racket/class
         racket/path
         racket/port
         racket/list
         racket/gui/base
         string-constants
         framework
         (prefix-in tr: trace/stacktrace)
         "drsig.rkt")

(provide tracing@)

(define-unit tracing@
  (import [prefix drracket:frame: drracket:frame^]
          [prefix drracket:rep: drracket:rep^]
          [prefix drracket:init: drracket:init^]
          [prefix drracket:unit: drracket:unit^])
  (export drracket:tracing^)
  
  (define-local-member-name
    get-tracing-text
    show-tracing
    tracing:add-line
    tracing:rest)
  (define tab-tracing<%>
    (interface ()
      get-tracing-text
      get-any-results?
      tracing:add-line
      tracing:reset))
  
  (define ellipses-cutoff 200)
  (define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key)))
  
  (define (print-call-trace inferred-name original? src args improper? depth)
    (when inferred-name
      (let ([name (cond
                    [(identifier? inferred-name) (syntax-e inferred-name)]
                    [else (object-name inferred-name)])]
            [rep (drracket:rep:current-rep)])
        (when (and name rep)
          (let ([canvas (send rep get-canvas)])
            (when canvas
              (let* ([frame (send canvas get-top-level-window)]
                     [tab (send frame get-current-tab)])
                (when (is-a? tab tab-tracing<%>)
                  (let ([sp (open-output-string)])
                    (let loop ([i depth])
                      (unless (zero? i)
                        (display " " sp)
                        (loop (- i 1))))
                    (fprintf sp "(")
                    (fprintf sp "~a" name)
                    (let loop ([args args])
                      (cond
                        [(null? args) (void)]
                        [(and (null? (cdr args)) improper?)
                         (fprintf sp " . ")
                         (fprintf sp "~v" (car args))]
                        [else
                         (let ([arg (car args)])
                           (fprintf sp " ")
                           (fprintf sp "~v" arg))
                         (loop (cdr args))]))
                    (fprintf sp ")")
                    (let ([sema (make-semaphore)])
                      ;; Disable breaks, so an exn handler can't
                      ;;  grab the DrRacket eventspacae:
                      (parameterize-break #f
                                          ;; Queue callback to write trace line ---
                                          ;; low priority, so that infinite loops don't stop the user
                                          ;;  from clicking "Break"
                                          (parameterize ([current-eventspace drracket:init:system-eventspace])
                                            (queue-callback
                                             (lambda ()
                                               (send tab tracing:add-line (get-output-string sp))
                                               (semaphore-post sema))
                                             #f)))
                      ;; Wait for the line to get written, so that the
                      ;;  trace output doesn't get too far behind (which
                      ;;  matters, again, for infinite loops)
                      (semaphore-wait sema)))))))))))
  
  (define-values/invoke-unit tr:stacktrace@
    (import tr:stacktrace-imports^) (export tr:stacktrace^))
  
  (define tab-mixin
    (mixin (drracket:unit:tab<%> drracket:rep:context<%>) (tab-tracing<%>)
      (inherit get-frame)
      
      (define tracing-visible? #f)
      (define/public (set-tracing-visible? v?) (set! tracing-visible? v?))
      (define/public (get-tracing-visible?) tracing-visible?)
      
      (define/augment (clear-annotations)
        (tracing:reset)
        (inner (void) clear-annotations))
      
      (define any-results? #f)
      (define/public (get-any-results?) any-results?)
      (define/public (tracing:reset)
        (set! any-results? #f)
        (send show-tracing-text lock #f)
        (send show-tracing-text erase)
        (send show-tracing-text auto-wrap #t)
        (send show-tracing-text insert (string-constant tracing-tracing-nothing-to-show))
        (send show-tracing-text lock #t))
      
      (define show-tracing-text (new text:hide-caret/selection%))
      (define/public (get-tracing-text) show-tracing-text)
      (send show-tracing-text lock #t)
      
      (define/public (tracing:add-line s)
        (let ([old-any? any-results?])
          (set! any-results? #t)
          (unless old-any?
            (send (get-frame) show-tracing))
          (send show-tracing-text begin-edit-sequence)
          (send show-tracing-text lock #f)
          (unless old-any?
            (send show-tracing-text erase)
            (send show-tracing-text auto-wrap #f))
          (let ([insert
                 (lambda (s)
                   (send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))])
            (cond
              [(<= (string-length s) ellipses-cutoff)
               (insert s)
               (insert "\n")]
              [else
               (insert (substring s 0 ellipses-cutoff))
               (insert " ")
               (let ([ell-start (send show-tracing-text last-position)])
                 (insert "...")
                 (let ([ell-end (send show-tracing-text last-position)])
                   (let ([para (send show-tracing-text last-paragraph)])
                     (insert "\n")
                     (send show-tracing-text change-style clickback-delta ell-start ell-end)
                     (send show-tracing-text set-clickback ell-start ell-end 
                           (lambda (t x y)
                             (send show-tracing-text begin-edit-sequence)
                             (send show-tracing-text lock #f)
                             (let ([line-start (send show-tracing-text paragraph-start-position para)]
                                   [line-end (send show-tracing-text paragraph-end-position para)])
                               (send show-tracing-text delete line-start line-end #f)
                               (send show-tracing-text insert s line-start 'same #f))
                             (send show-tracing-text lock #t)
                             (send show-tracing-text end-edit-sequence))))))]))
          (send show-tracing-text lock #t)
          (send show-tracing-text end-edit-sequence)))
      
      (super-new)))
  
  (define clickback-delta (make-object style-delta%))
  (send clickback-delta set-delta-foreground "BLUE")
  (send clickback-delta set-delta 'change-underline #t)
  
  (define frame-mixin 
    (mixin (drracket:frame:<%> drracket:unit:frame<%>) ()
      (inherit get-current-tab)
      (define show-tracing-menu-item #f)
      (define tracing-visible? #f)
      
      (define/augment (on-tab-change old new)
        (inner (void) on-tab-change old new)
        (send show-tracing-canvas set-editor (send new get-tracing-text))
        (cond
          [(eq? tracing-visible? (send new get-tracing-visible?))
           (void)]
          [(send new get-tracing-visible?)
           (show-tracing)]
          [else
           (hide-tracing)]))
      
      (define/override (add-show-menu-items show-menu)
        (super add-show-menu-items show-menu)
        (set! show-tracing-menu-item
              (new menu-item%
                   (parent show-menu)
                   (label (string-constant tracing-show-tracing-window))
                   (callback (lambda (x y) (toggle-tracing))))))
      
      (define/public (show-tracing)
        (set! tracing-visible? #t)
        (send show-tracing-menu-item set-label (string-constant tracing-hide-tracing-window))
        (send dragable-parent begin-container-sequence)
        (send dragable-parent change-children
              (lambda (l)
                (let ([without (remq show-tracing-canvas l)])
                  (append without (list show-tracing-canvas)))))
        (send dragable-parent set-percentages '(3/4 1/4))
        (send dragable-parent end-container-sequence))
      
      (define/private (hide-tracing)
        (set! tracing-visible? #f)
        (send show-tracing-menu-item set-label (string-constant tracing-show-tracing-window))
        (send dragable-parent change-children
              (lambda (l)
                (remq show-tracing-canvas l))))
      
      (define/private (toggle-tracing)
        (if tracing-visible?
            (hide-tracing)
            (show-tracing)))
      
      (define dragable-parent #f)
      (define show-tracing-parent-panel #f)
      (define show-tracing-canvas #f)
      
      (define/override (make-root-area-container cls parent)
        (set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent))
        (let ([root (make-object cls dragable-parent)])
          (set! show-tracing-canvas (new editor-canvas% 
                                         (parent dragable-parent)
                                         (editor (send (get-current-tab) get-tracing-text))))
          (send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l)))
          root))
      
      (super-new))))
