#lang racket/base
(require racket/gui/base
         framework
         racket/class)

;; how long between samples
(define pause-time 0.1)

;; gui updates occur every 'update-frequency' samples
(define update-frequency 4)

(define (make-prod-thread get-threads update-gui)
  (thread (lambda ()
            (define traces-table (make-hash))
            (let loop ([i 0])
              (sleep pause-time)
              (define new-traces
                (map (λ (t) (continuation-mark-set->context (continuation-marks t))) (get-threads)))
              (for* ([trace (in-list new-traces)]
                     [line (in-list trace)])
                (hash-set! traces-table line (cons trace (hash-ref traces-table line '()))))
              (cond
                [(zero? i)
                 (update-gui traces-table)
                 (loop update-frequency)]
                [else (loop (- i 1))])))))

(define (format-fn-name i)
  (define id (car i))
  (define src (cdr i))
  (cond
    [id (format "~a" id)]
    [src
     (format "~a:~a~a"
             (cond
               [(path? (srcloc-source src))
                (define-values (base name dir?) (split-path (srcloc-source src)))
                name]
               [else (srcloc-source src)])
             (if (srcloc-line src)
                 (format "~a:~a" (srcloc-line src) (srcloc-column src))
                 (srcloc-position src))
             (if id
                 (format ": ~a" id)
                 ""))]
    [else "???"]))

(define (insert-long-fn-name t i)
  (send t begin-edit-sequence)
  (send t erase)
  (let ([id (car i)]
        [src (cdr i)])
    (when src
      (send t insert
            (format "~a:~a"
                    (srcloc-source src)
                    (if (srcloc-line src)
                        (format "~a:~a"
                                (srcloc-line src)
                                (srcloc-column src))
                        (format ":~a" (srcloc-position src))))))
    (when (and id src)
      (send t insert "\n"))
    (when id
      (send t insert (format (format "~a" id))))
    (unless (or id src)
      (send t insert "???")))
  (send t end-edit-sequence))

(define (format-percentage n)
  (define trunc (floor (* n 100)))
  (format "~a%" (pad3 trunc)))

(define (pad3 n)
  (cond
    [(< n 10) (format "00~a" n)]
    [(< n 100) (format "0~a" n)]
    [else (format "~a" n)]))

(define cumulative-t%
  (class text:line-spacing%
    (init-field open-button vp ec1 lp info-editor)
    (inherit begin-edit-sequence
             end-edit-sequence
             erase
             find-position 
             get-admin
             dc-location-to-editor-location
             position-paragraph
             insert
             last-position
             highlight-range
             last-paragraph
             lock)
    
    (define gui-display-data '())
    (define clicked-srcloc-pr #f)
    (define line-to-source (make-hasheq))

    (define clear-old-pr void)
    
    (define/override (on-event event)
      (cond
        [(send event button-up? 'left)
         (define admin (get-admin))
         (when admin
           (send admin get-dc)
           (define-values (x y)
             (dc-location-to-editor-location (send event get-x) (send event get-y)))
           (define loc (find-position x y))
           (define para (position-paragraph loc))
           (set! clicked-srcloc-pr
                 (and (<= 0 para (last-paragraph)) (car (list-ref gui-display-data para))))
           (update-gui-display))]
        [else (void)]))

    (define/public (set-gui-display-data/refresh traces-table)
      (set! gui-display-data
            (sort (hash-map traces-table (λ (k v) (cons k v)))
                  >
                  #:key (λ (x) (length (cdr x)))))
      (update-gui-display))
    
    (define/public (clear-clicked)
      (set! clicked-srcloc-pr #f)
      (update-gui-display))
    
    (define/private (update-gui-display)
      (lock #f)
      (begin-edit-sequence)
      (erase)
      (set! line-to-source (make-hasheq))
      (clear-old-pr)
      (set! clear-old-pr void)
      (define denom-ht (make-hasheq))
      (define filtered-gui-display-data
        (for/list ([pr (in-list gui-display-data)])
          (define id (car pr))
          (define stacks (filter-stacks (cdr pr)))
          (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks)
          (cons id stacks)))
      (define denom-count (hash-count denom-ht))
      (let loop ([prs filtered-gui-display-data]
                 [first? #t]
                 [i 0])
        (cond
          [(null? prs) (void)]
          [else
           (define pr (car prs))
           (define fn (car pr))
           (define count (length (cdr pr)))
           (cond
             [(zero? count) (loop (cdr prs) first? i)]
             [else
              (unless first?
                (insert "\n"))
              (let ([before (last-position)])
                (hash-set! line-to-source i pr)
                (insert (format-percentage (/ count denom-count)))
                (insert (format " ~a" (format-fn-name fn)))
                (define after (last-position))
                (when (equal? (car pr) clicked-srcloc-pr)
                  (set! clear-old-pr (highlight-range before after "NavajoWhite"))))
              (loop (cdr prs) #f (+ i 1))])]))
      (lock #t)
      (end-edit-sequence)
      (update-info-editor clicked-srcloc-pr)
      (send open-button enable
            (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr))))))
    
    (define/private (filter-stacks stacks)
      (cond
        [(not clicked-srcloc-pr) stacks]
        [else
         (filter (λ (stack) (ormap (λ (stack-ent) (equal? clicked-srcloc-pr stack-ent))
                                   stack))
                 stacks)]))
         
    (define/public (open-current-pr)
      (when clicked-srcloc-pr
        (define src (cdr clicked-srcloc-pr))
        (when (path? (srcloc-source src))
          (printf "open ~s\n" (srcloc-source src))
          (when (number? (srcloc-position src))
            (printf "go to ~s\n" (srcloc-position src))))))
    
    (define/private (update-info-editor pr)
      (send vp change-children (λ (l) (if pr (list ec1 lp) (list ec1))))
      (when pr
        (insert-long-fn-name info-editor pr)))
    
    (super-new)))

(define (construct-gui f)
  (define info-editor (new text%))
  (define vp (new vertical-panel% [parent f]))
  (define ec1 (new editor-canvas% [parent vp]))
  (define lp (new vertical-panel% [parent vp] [stretchable-height #f]))
  (define ec2 (new editor-canvas%
                   [parent lp]
                   [min-height 100]
                   [stretchable-height #f]
                   [editor info-editor]))
  (define bp (new horizontal-panel% [stretchable-height #f] [parent lp] [alignment '(center center)]))
  (define open-button (new button%
                           [parent bp]
                           [label "Open"]
                           [callback
                            (λ (x y)
                              (send cumulative-t open-current-pr))]))
  (define unlock (new button%
                      [label "Show All"]
                      [parent bp]
                      [callback
                       (λ (x y)
                         (send cumulative-t clear-clicked))]))
  (define cumulative-t (new cumulative-t% 
                            [open-button open-button]
                            [vp vp]
                            [ec1 ec1]
                            [lp lp]
                            [info-editor info-editor]))
  (send ec1 set-editor cumulative-t)
  (send vp change-children (λ (l) (list ec1)))
  (send cumulative-t hide-caret #t)
  (send cumulative-t lock #t)
  (send info-editor auto-wrap #t)
  (values vp cumulative-t))

;; running an example outside of drscheme
#;
(begin
  (define evt (make-eventspace))
  (define f (parameterize ([current-eventspace evt])
              (new frame%
                   [label ""]
                   [width 400]
                   [height 800])))
  (define-values (panel cumulative-t) (construct-gui f))
  (send f show #t)
  
  (void (make-prod-thread (let ([t (current-thread)])
                            (λ () (list t)))
                          (λ (traces-table)
                            (parameterize ([current-eventspace evt])
                              (queue-callback
                               (λ () 
                                 (send cumulative-t set-gui-display-data/refresh traces-table)))))))
  
  (time (dynamic-require '(lib "scribblings/reference/reference.scrbl")
                         #f)))

;; tool code, for integration with drscheme
(begin
  (require drracket/tool
           racket/unit
           string-constants/string-constant)
  
  (define sc-show-sprof "Show SProfile")
  (define sc-hide-sprof "Hide SProfile")
  
  (provide tool@)
  (define tool@
    (unit
      (import drscheme:tool^)
      (export drscheme:tool-exports^)     
      (define (phase1) (void))
      (define (phase2) (void))
      
      (define-local-member-name
        show/hide-sprof-panel
        update-sprof-panel
        toggle-sprof-visiblity
        stop-profiling-thread
        start-profiling-thread
        get-threads-to-profile)
      
      (define unit-frame-mixin
        (mixin (drscheme:unit:frame<%>) ()
          (inherit get-current-tab)
          
          (define main-panel #f)
          (define sprof-main-panel #f)
          (define everything-else #f)
          (define cumulative-t #f)
          (define show/hide-menu-item #f)
          
          (define/public (show/hide-sprof-panel show?)
            (define main-children (send main-panel get-children))
            (send show/hide-menu-item set-label (if show? sc-hide-sprof sc-show-sprof))
            (unless (or (and show? (= 2 (length main-children)))
                        (and (not show?) (= 1 (length main-children))))
              (send main-panel change-children
                    (λ (l)
                      (if show?
                          (list everything-else sprof-main-panel)
                          (list everything-else))))))
          
          (define/override (make-root-area-container cls parent)
            (set! main-panel (super make-root-area-container panel:horizontal-dragable% parent))
            (set! everything-else (make-object cls main-panel))
            (set!-values (sprof-main-panel cumulative-t) (construct-gui main-panel))
            (send main-panel change-children (λ (l) (list everything-else)))
            everything-else)
          
          (define/augment (on-tab-change from-tab to-tab)
            (inner (void) on-tab-change from-tab to-tab)
            (send to-tab update-sprof-panel))
          
          (define/override (add-show-menu-items show-menu)
            (super add-show-menu-items show-menu)
            (set! show/hide-menu-item
                  (new menu-item%
                       [parent show-menu]
                       [label sc-show-sprof]
                       [callback 
                        (λ (x y)
                          (send (get-current-tab) toggle-sprof-visiblity))])))
          
          ;; FIX: the cumulative-t text object shouldn't be handed out like this
          ;; instead its contents need to be tab specific, so switching tabs
          ;; (ala the update-sprof-panel method) should change the contents of
          ;; the cumulative-t, presumably via the set-gui-display-data/refresh method.
          (define/public (get-cumulative-t) cumulative-t)
          
          (super-new)))
      
      (define tab-mixin
        (mixin (drscheme:unit:tab<%>) ()
          (inherit get-frame get-ints)
          (define prof-visible? #f)
          (define/public (toggle-sprof-visiblity)
            (set! prof-visible? (not prof-visible?))
            (cond
              [prof-visible?
               (start-profiling-thread)]
              [else
               (stop-profiling-thread)])
            (update-sprof-panel))
          (define/public (update-sprof-panel)
            (send (get-frame) show/hide-sprof-panel prof-visible?))
          
          (define profiling-thread #f)
          
          (define/public (stop-profiling-thread)
            (when profiling-thread
              (kill-thread profiling-thread))
            (set! profiling-thread #f))
          
          (define current-traces-table #f)
          
          (define/public (start-profiling-thread)
            (stop-profiling-thread)
            (set! profiling-thread (make-prod-thread 
                                    (λ () (send (get-ints) get-threads-to-profile))
                                    (λ (traces-table)
                                      (queue-callback
                                       (λ ()
                                         (send (send (get-frame) get-cumulative-t) set-gui-display-data/refresh traces-table)))))))
          
          (super-new)))
      
      (define system-custodian (current-custodian))
      
      (define repl-mixin
        (mixin (drscheme:rep:text<%>) ()
          (inherit get-user-custodian)
          (define/public (get-threads-to-profile)
            (define thds '())
            (let loop ([cust (get-user-custodian)])
              (for ([obj (in-list (custodian-managed-list cust system-custodian))])
                (cond
                  [(custodian? obj) (loop obj)]
                  [(thread? obj) (set! thds (cons obj thds))])))
            thds)

          ;; FIX
          ;; something needs to happen here so that the profiling gets shutdown when the repl dies.
          ;; the right call back isn't obvious, tho. :(
          
          (super-new)))
       
      (drscheme:get/extend:extend-tab tab-mixin)
      (drscheme:get/extend:extend-interactions-text repl-mixin)
      (drscheme:get/extend:extend-unit-frame unit-frame-mixin))))
