#lang racket/base
(require racket/class
         racket/path
         racket/gui/base
         framework
         racket/class/iop
         "interfaces.rkt"
         "stepper.rkt"
         (prefix-in sb: "../syntax-browser/embed.rkt")
	 (prefix-in sb: macro-debugger/syntax-browser/interfaces)
	 (prefix-in sb: macro-debugger/syntax-browser/partition)
         framework/notify)
(provide macro-stepper-frame-mixin)

(define-syntax override/return-false
  (syntax-rules ()
    [(override/return-false m ...)
     (begin (define/override (m) #f) ...)]))

(define (macro-stepper-frame-mixin base-frame%)
  (class* base-frame% (stepper-frame<%>)
    (init-field config)
    (init-field director)
    (init-field (filename #f))

    (define obsoleted? #f)

    (inherit get-area-container
             get-size
             set-label
             get-menu%
             get-menu-item%
             get-menu-bar
             get-file-menu
             get-edit-menu
             get-help-menu)

    (super-new (label (make-label))
               (width (send/i config config<%> get-width))
               (height (send/i config config<%> get-height)))

    (define/private (make-label)
      (if filename
          (string-append (path->string
                          (file-name-from-path filename))
                         (if obsoleted? " (old)" "")
                         " - Macro stepper")
          "Macro stepper"))

    ;; Grrr... we get a spurious on-size event sometime after the
    ;; frame is created, probably when the window-manager gets around
    ;; to doing something. Avoid unnecessary updates.
    (define-values (w0 h0) (get-size))
    (define/override (on-size w h)
      (send/i config config<%> set-width w)
      (send/i config config<%> set-height h)
      (unless (and (= w0 w) (= h0 h))
        (when (send/i config config<%> get-refresh-on-resize?)
          (send/i widget widget<%> update/preserve-view)))
      (set!-values (w0 h0) (values w h)))

    (define warning-panel
      (new horizontal-panel%
           (parent (get-area-container))
           (stretchable-height #f)
           (style '(deleted))))

    (define/public (get-macro-stepper-widget%)
      macro-stepper-widget%)

    (define/i widget widget<%>
      (new (get-macro-stepper-widget%)
           (parent (get-area-container))
           (director director)
           (config config)))
    (define/i controller sb:controller<%>
      (send/i widget widget<%> get-controller))

    (define/public (get-widget) widget)
    (define/public (get-controller) controller)

    (define/public (add-obsoleted-warning)
      (unless obsoleted?
        (set! obsoleted? #t)
        (new warning-canvas%
             (warning
              (string-append
               "Warning: This macro stepper session is obsolete. "
               "The program may have changed."))
             (parent warning-panel))
        (set-label (make-label))
        (send (get-area-container) change-children
              (lambda (children)
                (cons warning-panel
                      (remq warning-panel children))))))

    ;; Set up menus

    (override/return-false file-menu:create-new?
                           file-menu:create-open?
                           file-menu:create-open-recent?
                           file-menu:create-revert?
                           file-menu:create-save?
                           file-menu:create-save-as?
                           ;file-menu:create-print?
                           edit-menu:create-undo?
                           edit-menu:create-redo?
                           ;edit-menu:create-cut?
                           ;edit-menu:create-paste?
                           edit-menu:create-clear?)

    (define stepper-menu
      (new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))

    (define/override (file-menu:between-save-as-and-print file-menu)
      (super file-menu:between-save-as-and-print file-menu)
      (new separator-menu-item% (parent file-menu))
      (new (get-menu-item%)
           (label "Duplicate stepper")
           (parent file-menu)
           (callback (lambda _ (send/i widget widget<%> duplicate-stepper))))
      (new (get-menu-item%)
           (label "Duplicate stepper (current term only)")
           (parent file-menu)
           (callback (lambda _ (send/i widget widget<%> show-in-new-frame))))
      (new separator-menu-item% (parent file-menu)))

    (notify:menu-option/notify-box stepper-menu
                                   "View syntax properties"
                                   (get-field props-shown? config))

    (let ([partition-menu
           (new (get-menu%)
                (label "Foreground colors")
                (parent stepper-menu))])
      (for ([p (in-list (sb:partition-choices))])
        (define this-choice
          (new checkable-menu-item%
               (label (car p))
               (parent partition-menu)
               (callback
                (lambda _ (send/i controller sb:controller<%> set-primary-partition-factory
                             (cdr p))))))
        (send/i controller sb:controller<%> listen-primary-partition-factory
                (lambda (func) (send this-choice check (eq? func (cdr p)))))))

    (let ([id-menu
           (new (get-menu%)
                (label "Identifier=?")
                (parent stepper-menu))])
      (for ([p (in-list (sb:identifier=-choices))])
        (define this-choice
          (new checkable-menu-item%
               (label (car p))
               (parent id-menu)
               (callback
                (lambda _ (send/i controller sb:controller<%> set-identifier=? (cdr p))))))
        (send/i controller sb:controller<%> listen-identifier=?
                (lambda (func) (send this-choice check (eq? func (cdr p)))))))

    (cond [(assoc (send/i config config<%> get-identifier=?)
                  (sb:identifier=-choices))
           => (lambda (p)
                (send/i controller sb:controller<%> set-identifier=? (cdr p)))])

    (cond [(assoc (send/i config config<%> get-primary-partition)
                  (sb:partition-choices))
           => (lambda (p)
                (send/i controller sb:controller<%> set-primary-partition-factory (cdr p)))])
    
    (new (get-menu-item%)
         (label "Clear selection")
         (parent stepper-menu)
         (callback
          (lambda _ (send/i controller sb:controller<%> 
			   set-selected-syntax #f))))

    (new separator-menu-item% (parent stepper-menu))

    (notify:menu-option/notify-box stepper-menu
                                   "Show macro hiding panel"
                                   (get-field show-hiding-panel? config))

    (new (get-menu-item%)
         (label "Remove selected term")
         (parent stepper-menu)
         (callback (lambda _ (send/i widget widget<%> remove-current-term))))
    (new (get-menu-item%)
         (label "Reset mark numbering")
         (parent stepper-menu)
         (callback (lambda _ (send/i widget widget<%> reset-primary-partition))))
    (let ([extras-menu
           (new (get-menu%)
                (label "Extra options")
                (parent stepper-menu))])
      (new checkable-menu-item%
           (label "Always suffix marked identifiers")
           (parent extras-menu)
           (callback
            (lambda (i e)
              (send/i config config<%> set-suffix-option
                     (if (send i is-checked?)
                         'always
                         'over-limit))
              (send/i widget widget<%> update/preserve-view))))
      (notify:menu-option/notify-box extras-menu
                                     "Factor out common context?"
                                     (get-field split-context? config))
      (notify:menu-option/notify-box extras-menu
                                     "Highlight redex/contractum"
                                     (get-field highlight-foci? config))
      (let ([taint-icons-menu
             (new (get-menu%)
                  (label "Show taint icons")
                  (parent extras-menu))])
        (define choices
          '((char . "Use Unicode characters")
            (snip . "Use custom snips")
            (#f   . "Do not show")))
        (define taint-icons-box
          (linked-notify-box (get-field taint-icons config) choices))
        (notify:menu-group/notify-box taint-icons-menu
                                      (map cdr choices)
                                      taint-icons-box))
      #|
      (notify:menu-option/notify-box extras-menu
                                     "Highlight frontier"
                                     (get-field highlight-frontier? config))
      |#
      (notify:menu-option/notify-box extras-menu
                                     "Include renaming steps"
                                     (get-field show-rename-steps? config))
      (notify:menu-option/notify-box extras-menu
                                     "One term at a time"
                                     (get-field one-by-one? config))
      (notify:menu-option/notify-box extras-menu
                                     "Refresh on resize"
                                     (get-field refresh-on-resize? config))
      (notify:menu-option/notify-box extras-menu
                                     "Close old stepper on Run"
                                     (get-field close-on-reset-console? config))
      (notify:menu-option/notify-box extras-menu
                                     "Draw binding arrows"
                                     (get-field draw-arrows? config))
      (notify:menu-option/notify-box extras-menu
                                     "Enable reader abbreviations"
                                     (get-field pretty-abbrev? config))
      (notify:menu-option/notify-box extras-menu
                                     "Extra navigation"
                                     (get-field extra-navigation? config)))

    ;; fixup-menu : menu -> void
    ;; Delete separators at beginning/end and duplicates in middle
    (define/private (fixup-menu menu)
      (define items
        (filter (lambda (i) (not (send i is-deleted?)))
                (send menu get-items)))
      (define (delete-seps-loop items)
        (if (and (pair? items) (is-a? (car items) separator-menu-item%))
            (begin (send (car items) delete)
                   (delete-seps-loop (cdr items)))
            items))
      (define (middle-loop items)
        (cond
         [(and (pair? items) (is-a? (car items) separator-menu-item%))
          (middle-loop (delete-seps-loop (cdr items)))]
         [(pair? items)
          (middle-loop (cdr items))]
         [else null]))
      (middle-loop (delete-seps-loop items))
      (delete-seps-loop (reverse items))
      (void))

    (for ([menu (send (get-menu-bar) get-items)])
      (fixup-menu menu))
    (frame:remove-empty-menus this)
    (frame:reorder-menus this)))

;; Linked notify boxes

(define (linked-notify-box old-nb old=>new)
  (define new=>old (map (lambda (p) (cons (cdr p) (car p))) old=>new))
  (define (new->old v) (cond [(assoc v new=>old) => cdr] [else #f]))
  (define (old->new v) (cond [(assoc v old=>new) => cdr] [else #f]))
  (define new-nb (new notify:notify-box% (value (old->new (send old-nb get)))))
  ;; Need to compare with current value to avoid notification loops:
  (define ((forward convert to-nb) v)
    (let ([v* (convert v)]) (unless (equal? v* (send to-nb get)) (send to-nb set v*))))
  (send new-nb listen (forward new->old old-nb))
  (send old-nb listen (forward old->new new-nb))
  new-nb)

;; Stolen from stepper

(define warning-color "yellow")
(define warning-font normal-control-font)

(define warning-canvas%
  (class canvas%
    (init-field warning)
    (inherit get-dc get-client-size)
    (define/override (on-paint)
      (let ([dc (get-dc)])
        (send dc set-font warning-font) 
        (let-values ([(cw ch) (get-client-size)]
                     [(tw th dont-care dont-care2) 
                      (send dc get-text-extent warning)])
          (send dc set-pen 
                (send the-pen-list find-or-create-pen warning-color 1 'solid))
          (send dc set-brush
                (send the-brush-list find-or-create-brush warning-color 'solid))
          (send dc draw-rectangle 0 0 cw ch)
          (send dc draw-text 
                warning
                (- (/ cw 2) (/ tw 2))
                (- (/ ch 2) (/ th 2))))))
    (super-new)
    (inherit min-width min-height stretchable-height)
    (let-values ([(tw th dc dc2)
                  (send (get-dc) get-text-extent warning warning-font)])
      (min-width (+ 2 (inexact->exact (ceiling tw))))
      (min-height (+ 2 (inexact->exact (ceiling th)))))
    (stretchable-height #f)))
