(module debugger mzscheme
  (require
   (lib "class.ss")
   (lib "list.ss")
   (lib "string.ss")
   (lib "bitmap-label.ss" "mrlib")
   (lib "framework.ss" "framework")
   (lib "mred.ss" "mred")
   (prefix dd: "debugger-defs.ss")
   (prefix ocaml: "util.ss"))
  (provide
   definitions-text-mixin
   tab-mixin
   unit-frame-mixin)
  
  (define (definitions-text-mixin drscheme:unit:definitions-text<%> get-settings-thunk)
    (mixin (drscheme:unit:definitions-text<%> scheme:text<%> ocaml:definitions-text<%>) ()
      (inherit
        backward-match
        classify-position
        forward-match
        get-tab
        get-text
        get-top-level-window
        highlight-range
        last-position
        scroll-to-position)
      (define ocaml:debug:in-handler #f)
      (define ocaml:debug:err-handler #f)
      (define ocaml:debug-current-time #f)
      (define ocaml:debug-current-direction #f)
      (define ocaml:debug-highlight-start #f)
      (define ocaml:debug-highlight-end #f)
      (define ocaml:debug-unhighlight-thunk #f)
      (define ocaml:debug-value-highlight-start #f)
      (define ocaml:debug-value-highlight-end #f)
      (define ocaml:debug-value-unhighlight-thunk #f)
      (define ocaml:debug-breakpoints (make-hash-table))
      
      (define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
      (define bp-brush (send the-brush-list find-or-create-brush "red" 'solid))
      (define bp-mo-pen (send the-pen-list find-or-create-pen "darkgray" 1 'solid))
      (define bp-mo-brush (send the-brush-list find-or-create-brush "pink"
                                'solid))
      (define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
      (define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
                                 'solid))
      (define pc-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
      (define pc-brush (send the-brush-list find-or-create-brush "forestgreen" 'solid))
      (define pc-err-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
      (define pc-err-brush (send the-brush-list find-or-create-brush "red" 'solid))
      (define pc-brk-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
      (define pc-brk-brush (send the-brush-list find-or-create-brush "gray" 'solid))
      
      (super-new)
      
      (define/public (ocaml:debug:get-breakpoints) ocaml:debug-breakpoints)
      
      (define (average . values)
        (/ (apply + values) (length values)))
      
      (define/augment (after-set-next-settings settings)
        (inner (void) after-set-next-settings settings)
        (let ([frame (send (get-tab) get-frame)])
          (when frame
            (send frame ocaml:update-button-visibility/settings settings))))
      
      (define/public (ocaml:get-direction) ocaml:debug-current-direction)
      
      (define/public (ocaml:debug:set-in-handler handler)
        (set! ocaml:debug:in-handler handler))
      
      (define/public (ocaml:debug:set-err-handler handler)
        (set! ocaml:debug:err-handler handler))
      
      (define/public (ocaml:debug:pause-handlers)
        (when ocaml:debug:in-handler
          (thread-suspend ocaml:debug:in-handler))
        (when ocaml:debug:err-handler
          (thread-suspend ocaml:debug:err-handler)))
      
      (define/public (ocaml:debug:resume-handlers)
        (when ocaml:debug:in-handler
          (thread-resume ocaml:debug:in-handler))
        (when ocaml:debug:err-handler
          (thread-resume ocaml:debug:err-handler)))
      
      (define/public (ocaml:set-debug-time time)
        (let ([old-time (or ocaml:debug-current-time 0)]
              [new-time (or time 0)])
          (set! ocaml:debug-current-time time)
          (if (< old-time new-time)
              (set! ocaml:debug-current-direction 'forward)
              (set! ocaml:debug-current-direction 'backward))))
      
      (define/public (ocaml:set-debug-status message)
        (define frame (send (get-tab) get-frame))
        (if ocaml:debug-current-time
            (send frame update-status-line 'ocaml:debugger
                  (clean-status (format "(Time: ~a) ~a" ocaml:debug-current-time message)))
            (send frame update-status-line 'ocaml:debugger (clean-status message))))
      
      (define/augment (ocaml:clean-up)
        (inner (void) ocaml:clean-up)
        (ocaml:reset-highlighting)
        (set! ocaml:debug:in-handler #f)
        (set! ocaml:debug:err-handler #f)
        (set! ocaml:debug-current-time #f)
        (set! ocaml:debug-current-direction #f)
        (send (get-tab) ocaml:kill-debug)
        (send (send (get-tab) get-frame) ocaml:hide-debug))
      
      (inherit
        dc-location-to-editor-location
        editor-location-to-dc-location
        invalidate-bitmap-cache
        get-canvas)
      
      (define/private (find-char-box text left-pos right-pos)
        (let ([xlb (box 0)]
              [ylb (box 0)]
              [xrb (box 0)]
              [yrb (box 0)])
          (send text position-location left-pos xlb ylb #t)
          (send text position-location right-pos xrb yrb #f)
          (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location
                                               (unbox xlb) (unbox ylb))]
                        [(xl yl) (dc-location-to-editor-location xl-off yl-off)]
                        [(xr-off yr-off) (send text editor-location-to-dc-location
                                               (unbox xrb) (unbox yrb))]
                        [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
            (values xl yl xr yr))))
      
      (define (clean-status s)
	(substring (regexp-replace* #rx"\n" s " ") 0 (min (string-length s) 200)))
      
      (define/override (on-event event)
        (if (ocaml:lang-settings? (get-settings-thunk))
            (cond
              [(send event button-down? 'right)
               (let-values ([(pos text) (ocaml:get-pos/text event this)])
                 (if (and pos text)
                     (let ([menu (make-object popup-menu% #f)]
                           [break-status (hash-table-get ocaml:debug-breakpoints pos (lambda () #f))])
                       (make-object menu-item%
                         (if break-status
                             "Remove pause at this point"
                             "Pause at this point")
                         menu
                         (lambda (item evt)
                           (hash-table-put! ocaml:debug-breakpoints pos (not break-status))
                           (when (send (get-tab) ocaml:get-debug-process)
                             (dd:update-breakpoints (get-tab) ocaml:debug-breakpoints))
                           (invalidate-bitmap-cache)))
                       (send (get-canvas) popup-menu menu
                             (+ 1 (inexact->exact (floor (send event get-x))))
                             (+ 1 (inexact->exact (floor (send event get-y))))))
                     (super on-event event)))]
              [(send (get-tab) ocaml:get-debug-process)
               (cond
                 [(or (send event moving?) (send event leaving?))
                  (let-values ([(pos text) (ocaml:get-pos/text event this)])
                    (when pos
                      (ocaml:jump-to-debug-token pos)))
                  (super on-event event)]
                 [(send event button-down? 'middle)]
                 [(send event button-up? 'middle)
                  (let-values ([(pos text) (ocaml:get-pos/text event this)])
                    (when pos
                      (ocaml:set-breakpoint pos)))]
                 [else (super on-event event)])]
              [else (super on-event event)])
            (super on-event event)))
      
      (define/override (on-paint before dc left top right bottom dx dy draw-caret)
        (super on-paint before dc left top right bottom dx dy draw-caret)
        (when (not before)
          (hash-table-for-each
           ocaml:debug-breakpoints
             (lambda (pos enabled?)
               (when (and (>= pos 0) enabled? #;(or enabled? (and mouse-over-pos (= mouse-over-pos pos))))
                 (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
                               [(diameter) (max 0 (- xr xl))]
                               [(yoff) (/ (- yr yl diameter) 2)])
                   (let ([op (send dc get-pen)]
                         [ob (send dc get-brush)])
                     (case enabled?
                       [(#t) (send dc set-pen bp-pen)
                             (send dc set-brush bp-brush)]
                       [(#f) (send dc set-pen bp-mo-pen)
                             (send dc set-brush bp-mo-brush)]
                       [else (send dc set-pen bp-tmp-pen)
                             (send dc set-brush bp-tmp-brush)])
                     ;(drscheme:arrow:draw-arrow dc xl yl xr yr dx dy)
                     (send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter)
                     #;
                     (send dc draw-polygon stop-sign
                           (+ xl dx)
                           (+ yl dy 2))
                     (send dc set-pen op)
                     (send dc set-brush ob)))))))
          (let ([pos (send (get-tab) get-pc)])
            (when pos
              (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)]
                            [(ym) (average yl yr)])
                (let ([op (send dc get-pen)]
                      [ob (send dc get-brush)])
                  (case (send (get-tab) get-break-status)
                    [(error) (send dc set-pen pc-err-pen)
                             (send dc set-brush pc-err-brush)]
                    [(break) (send dc set-pen pc-brk-pen)
                             (send dc set-brush pc-brk-brush)]
                    [else    (send dc set-pen pc-pen)
                             (send dc set-brush pc-brush)]))
               #;(drscheme:arrow:draw-arrow dc xl ym xr ym dx dy))
              )))
      
      (define/public (ocaml:jump-to-debug-token pos)
        (define id-end (forward-match pos (last-position)))
        (define id-start (and id-end (backward-match id-end 0)))
        (when
            (and
             id-start
             (> id-end pos)
             (eq? 'identifier (classify-position id-start)))
          (ocaml:set-debug-value-highlighting id-start id-end)
          (dd:inspect-value (get-tab) (get-text id-start id-end))))
      
      (define/public (ocaml:set-breakpoint pos)
        (define-values (num address line-num start-char end-char)
          (dd:update-breakpoints (get-tab) pos))
        (highlight-range pos (add1 pos) (make-object color% "Red"))
        (scroll-to-position pos)
        #;(define id-end (forward-match pos (last-position)))
        #;(define id-start (and id-end (backward-match id-end 0)))
        #;(when
              (and
               id-start
               (> id-end pos)
               (eq? 'identifier (classify-position id-start)))
            (ocaml:set-debug-highlighting id-start id-end)
            (dd:inspect-value (get-tab) (get-text id-start id-end))))
      
      (define/augment (ocaml:reset-highlighting)
        (define frame (send (get-tab) get-frame))
        (inner (void) ocaml:reset-highlighting)
        (when ocaml:debug-unhighlight-thunk
          (ocaml:debug-unhighlight-thunk)
          (set! ocaml:debug-highlight-start #f)
          (set! ocaml:debug-highlight-end #f)
          (set! ocaml:debug-unhighlight-thunk #f))
        (ocaml:reset-minor-debug-highlighting))
      
      (define/public (ocaml:reset-minor-debug-highlighting)
        (define frame (send (get-tab) get-frame))
        (when ocaml:debug-value-unhighlight-thunk
          (ocaml:debug-value-unhighlight-thunk)
          (set! ocaml:debug-value-highlight-start #f)
          (set! ocaml:debug-value-highlight-end #f)
          (set! ocaml:debug-value-unhighlight-thunk #f))
	(send frame open-status-line 'ocaml:debugger)
        (send frame update-status-line 'ocaml:debugger #f))
      
      (define/public (ocaml:set-debug-value-highlighting start end)
        (unless (and
                 (eq? ocaml:debug-value-highlight-start start)
                 (eq? ocaml:debug-value-highlight-end end))
          (ocaml:reset-minor-debug-highlighting)
          (set! ocaml:debug-value-highlight-start start)
          (set! ocaml:debug-value-highlight-end end)
          (set! ocaml:debug-value-unhighlight-thunk
                (highlight-range
                 start end
                 (make-object color% "MediumGoldenrod")
                 #f #f 'high))))
      
      (define/public (ocaml:set-debug-highlighting start end)
        (unless (and
                 (eq? ocaml:debug-highlight-start start)
                 (eq? ocaml:debug-highlight-end end))
          (ocaml:reset-highlighting)
          (set! ocaml:debug-highlight-start start)
          (set! ocaml:debug-highlight-end end)
          (set! ocaml:debug-unhighlight-thunk
                (highlight-range start end (make-object color% "lavender")))))))

  (define (tab-mixin drscheme:unit:tab<%>)
    (mixin (drscheme:unit:tab<%>) ()
      (inherit get-frame)
      ;; set at mode begin
      (define ocaml:in-debug #f)
      (define ocaml:debug-process #f)
      (super-new)
      (define/override (break-callback)
        (ocaml:kill-debug)
        (send (get-frame) ocaml:hide-debug)
        (super break-callback))
      (define/public (ocaml:kill-debug)
        (when (ocaml:process? ocaml:debug-process)
          (let ([proc (ocaml:process-proc ocaml:debug-process)])
            (subprocess-kill proc #f)
            (subprocess-kill proc #t)))
        (set! ocaml:debug-process #f))
      (define/public (ocaml:get-debug-process) ocaml:debug-process)
      (define/public (ocaml:set-debug-process process-obj)
        (set! ocaml:debug-process process-obj))))
  
  (define (unit-frame-mixin drscheme:unit:frame<%> get-settings-thunk get-lang)
    (mixin (drscheme:unit:frame<%>) (ocaml:unit:frame<%>)
      (inherit
        get-button-panel
        get-definitions-canvas
        get-definitions-text
        get-interactions-text
        get-current-tab
        open-status-line
        close-status-line
        update-status-line
        save)
      
      (define ocaml:debug-parent-panel 'uninitialized-debug-parent-panel)
      (define ocaml:debug-panel 'uninitialized-debug-panel)
      (define/override (get-definitions/interactions-panel-parent)
        (set! ocaml:debug-parent-panel
              (make-object vertical-panel%
                (super get-definitions/interactions-panel-parent)))
        (set! ocaml:debug-panel (instantiate horizontal-panel% ()
                                  (parent ocaml:debug-parent-panel)
                                  (stretchable-height #f)
                                  (alignment '(center center))
                                  (style '(border))))
        (send ocaml:debug-parent-panel change-children (λ (l) null))
        #;(instantiate button% ()
            (label "Hide")
            (parent ocaml:debug-panel)
            (callback (λ (x y) (ocaml:hide-debug)))
            (stretchable-height #t))
        (make-object vertical-panel% ocaml:debug-parent-panel))
      
      (super-new)
      
      (define ocaml:debugger-button-parent-panel
        (new horizontal-panel%
             [parent (get-button-panel)]
             [stretchable-width #f]
             [stretchable-height #f]))
      (define ocaml:debugger-button
        (new button%
             [label "Save and Debug"]
             [parent ocaml:debugger-button-parent-panel]
             [callback
              (λ (button evt)
                (save)
                (dd:debug-callback
                 (get-definitions-text)
                 (send button get-parent)
                 (get-settings-thunk)))]))
      
      (define/public (ocaml:hide-debug)
        (when (and (object? ocaml:debug-parent-panel)
	  (member ocaml:debug-panel (send ocaml:debug-parent-panel get-children)))
          (send ocaml:debug-parent-panel change-children
                (λ (l) (remq ocaml:debug-panel l)))))
      
      (define/public (ocaml:show-debug)
        (unless (member ocaml:debug-panel (send ocaml:debug-parent-panel get-children))
          (send ocaml:debug-parent-panel change-children
                (λ (l) (cons ocaml:debug-panel l)))))
      
      (define/override (execute-callback)
        (when (eq? (system-type 'os) 'windows)
          (let-values ([(proc in out err)
                        (subprocess #f #f #f "c:\\cygwin\\bin\\killall.exe" "-v" "-9" "ocamlrun")])
            (subprocess-wait proc)
            (sleep 0.1)))
        (send (get-current-tab) ocaml:kill-debug)
        (super execute-callback))
      
      (define/augment (on-close)
        (inner (void) on-close)
        (when (eq? (system-type 'os) 'windows)
          (let-values ([(proc in out err)
                        (subprocess #f #f #f "c:\\cygwin\\bin\\killall.exe" "-v" "-9" "ocamlrun")])
            (subprocess-wait proc)
            (sleep 0.1))))
      
      ;; single-action: reverse
      ;; "Execute backwards until the previous breakpoint or the beginning of the program."
      (define ocaml:reverse-button
        (instantiate button% ()
          [label "Reverse"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "reverse" 'backward))]
          [enabled #t]))
      
      ;; repeat-action: previous
      ;; "Execute backwards until the previous event, skipping any function calls."
      (define ocaml:previous-button
        (instantiate button% ()
          [label "Previous"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "previous" 'backward))]
          [enabled #t]))
      
      ;; repeat-action: start
      ;; "Execute backwards until just before the current function call."
      (define ocaml:start-button
        (instantiate button% ()
          [label "Start"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "start" 'backward))]
          [enabled #t]))
      
      ;; repeat-action: backstep
      ;; "Execute backwards until the previous event, entering any function calls."
      (define ocaml:backstep-button
        (instantiate button% ()
          [label "Backstep"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "backstep" 'backward))]
          [enabled #t]))
      
      ;; break-process: break
      ;; "Stop execution."
      (define ocaml:break-button
        (instantiate button% ()
          [label "Break"]
          [parent ocaml:debug-panel]
          [callback (λ (button evt) (dd:break-callback (get-current-tab)))]
          [enabled #t]))
      
      ;; repeat-action: step
      ;; "Execute forwards until the next event, entering any function calls."
      (define ocaml:step-button
        (instantiate button% ()
          [label "Step"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "step" 'forward))]
          [enabled #t]))
      
      ;; repeat-action: finish
      ;; "Execute forwards until just after the current function call."
      (define ocaml:finish-button
        (instantiate button% ()
          [label "Finish"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "finish" 'forward))]
          [enabled #t]))
      
      ;; repeat-action: next
      ;; "Execute forwards until the next event, skipping any function calls."
      (define ocaml:next-button
        (instantiate button% ()
          [label "Next"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "next" 'forward))]
          [enabled #t]))
      
      ;; single-action: run
      ;; "Execute forwards until the next breakpoint or the end of the program."
      (define ocaml:run-button
        (instantiate button% ()
          [label "Run"]
          [parent ocaml:debug-panel]
          [callback
           (λ (button evt)
             (dd:repeat-action-callback (get-current-tab) "run" 'forward))]
          [enabled #t]))
      
      (define/augment (on-tab-change old-tab new-tab)
        (inner (void) on-tab-change old-tab new-tab)
        (ocaml:update-button-visibility/tab new-tab))
      (define/public (ocaml:update-button-visibility/tab tab)
        (ocaml:update-button-visibility/settings (send (send tab get-defs) get-next-settings)))

      (define/pubment (ocaml:update-button-visibility/settings settings)
        (inner (void) ocaml:update-button-visibility/settings settings)
        (when (object? ocaml:debugger-button-parent-panel)
          (let ([visible? (send (get-lang settings) capability-value 'ocaml:debug-button)])
            (send ocaml:debugger-button-parent-panel change-children
                  (λ (l)
                    (if visible?
                        (list ocaml:debugger-button)
                        '()))))))
      
      (define/public (ocaml:debugger:get-button) ocaml:debugger-button)
      (send (get-button-panel) change-children
            (λ (l)
              (cons ocaml:debugger-button-parent-panel
                    (remove ocaml:debugger-button-parent-panel l))))
      (ocaml:update-button-visibility/tab (get-current-tab)))))