
#lang scheme/base
(require scheme/class
         scheme/unit
         scheme/list
         scheme/file
         scheme/match
         scheme/gui
         framework/framework
         syntax/boundmap
         "interfaces.ss"
         "stepper.ss"
         "prefs.ss"
         "warning.ss"
         "hiding-panel.ss"
         (prefix-in sb: "../syntax-browser/embed.ss")
         (prefix-in sb: "../syntax-browser/params.ss")
         "../model/deriv.ss"
         "../model/deriv-util.ss"
         "../model/trace.ss"
         "../model/steps.ss"
         "cursor.ss"
         "../util/notify.ss")
(provide macro-stepper-frame-mixin)

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

    (define obsoleted? #f)

    (inherit get-area-container
             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 config get-width))
               (height (send 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"))

    (define/override (on-size w h)
      (send config set-width w)
      (send config set-height h)
      (send widget update/preserve-view))

    (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?
                           ;edit-menu:create-find?
                           ;edit-menu:create-find-again?
                           edit-menu:create-replace-and-find-again?)

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

    (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 widget
      (new (get-macro-stepper-widget%)
           (parent (get-area-container))
           (config config)))
    (define controller (send 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

    (menu-option/notify-box stepper-menu
                            "Show syntax properties"
                            (get-field show-syntax-properties? config))

    (let ([id-menu
           (new (get-menu%)
                (label "Identifier=?")
                (parent stepper-menu))])
      (for-each (lambda (p)
                  (let ([this-choice
                         (new checkable-menu-item%
                              (label (car p)) 
                              (parent id-menu)
                              (callback
                               (lambda _ 
                                 (send controller set-identifier=? p))))])
                    (send controller listen-identifier=?
                          (lambda (name+func)
                            (send this-choice check
                                  (eq? (car name+func) (car p)))))))
                (sb:identifier=-choices)))

    (let ([identifier=? (send config get-identifier=?)])
      (when identifier=?
        (let ([p (assoc identifier=? (sb:identifier=-choices))])
          (send controller set-identifier=? p))))

    (new (get-menu-item%)
         (label "Clear selection")
         (parent stepper-menu)
         (callback
          (lambda _ (send controller set-selected-syntax #f))))

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

    (menu-option/notify-box stepper-menu
                            "Show macro hiding panel"
                            (get-field show-hiding-panel? config))
    #;
    (new (get-menu-item%)
         (label "Show in new frame")
         (parent stepper-menu)
         (callback (lambda _ (send widget show-in-new-frame))))
    (new (get-menu-item%)
         (label "Remove selected term")
         (parent stepper-menu)
         (callback (lambda _ (send widget remove-current-term))))
    (new (get-menu-item%)
         (label "Reset mark numbering")
         (parent stepper-menu)
         (callback (lambda _ (send 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)
              (sb:current-suffix-option
               (if (send i is-checked?)
                   'always
                   'over-limit))
              (send widget update/preserve-view))))
      (menu-option/notify-box extras-menu
                              "Highlight redex/contractum"
                              (get-field highlight-foci? config))
      (menu-option/notify-box extras-menu
                              "Highlight frontier"
                              (get-field highlight-frontier? config))
      (menu-option/notify-box extras-menu
                              "Include renaming steps"
                              (get-field show-rename-steps? config))
      (menu-option/notify-box extras-menu
                              "One term at a time"
                              (get-field one-by-one? config))
      (menu-option/notify-box extras-menu
                              "Suppress warnings"
                              (get-field suppress-warnings? config))
      (menu-option/notify-box extras-menu
                              "Extra navigation"
                              (get-field extra-navigation? config))
      (menu-option/notify-box extras-menu
                              "Force block->letrec transformation"
                              (get-field force-letrec-transformation? config))
      (menu-option/notify-box extras-menu
                              "(Debug) Catch internal errors?"
                              (get-field debug-catch-errors? config)))

    (frame:reorder-menus this)))

;; 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)))
