
(module gui mzscheme
  (require (lib "class.ss")
           (lib "unit.ss")
           (lib "list.ss")
           (lib "file.ss")
           (lib "plt-match.ss")
           (lib "mred.ss" "mred")
           (lib "framework.ss" "framework")
           (lib "boundmap.ss" "syntax")
           "interfaces.ss"
           "prefs.ss"
           "warning.ss"
           "hiding-panel.ss"
           (prefix sb: "../syntax-browser/embed.ss")
           (prefix sb: "../syntax-browser/params.ss")
           "../model/deriv.ss"
           "../model/deriv-util.ss"
           "../model/trace.ss"
           "../model/hide.ss"
           "../model/steps.ss"
           "cursor.ss"
           "util.ss")

  (provide pre-stepper@
           view@
           context-menu-extension@
           browser-extension@)

  ;; Struct for one-by-one stepping

  (define-struct (prestep protostep) (foci1 e1))
  (define-struct (poststep protostep) (foci2 e2))

  (define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
  (define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))

  ;; TermRecords

  (define-struct trec (deriv synth-deriv estx raw-steps steps definites) #f)

  (define (new-trec deriv)
    (make-trec deriv #f #f #f #f #f))

  ;; trec:invalidate-synth! : TermRecord -> void
  ;; Invalidates cached parts that depend on macro-hiding policy
  (define (trec:invalidate-synth! trec)
    (set-trec-synth-deriv! trec #f)
    (set-trec-estx! trec #f)
    (set-trec-raw-steps! trec #f)
    (set-trec-definites! trec #f)
    (trec:invalidate-steps! trec))

  ;; trec:invalidate-steps! : TermRecord -> void
  ;; Invalidates cached parts that depend on reductions config
  (define (trec:invalidate-steps! trec)
    (set-trec-steps! trec #f))

  ;; Macro Stepper

  (define view@
    (unit
      (import prefs^
              view-base^
              (prefix sb: sb:widget^))
      (export view^)

      (define macro-stepper-config%
        (class object%
          (field/notify width (notify-box/pref pref:width))
          (field/notify height (notify-box/pref pref:height))
          (field/notify macro-hiding? (notify-box/pref pref:macro-hiding?))
          (field/notify show-syntax-properties?
                        (notify-box/pref pref:show-syntax-properties?))
          (field/notify show-hiding-panel?
                        (notify-box/pref pref:show-hiding-panel?))
          (field/notify hide-primitives?
                        (notify-box/pref pref:hide-primitives?))
          (field/notify hide-libs?
                        (notify-box/pref pref:hide-libs?))
          (field/notify highlight-foci?
                        (notify-box/pref pref:highlight-foci?))
          (field/notify highlight-frontier?
                        (notify-box/pref pref:highlight-frontier?))
          (field/notify show-rename-steps?
                        (notify-box/pref pref:show-rename-steps?))
          (field/notify suppress-warnings?
                        (notify-box/pref pref:suppress-warnings?))
          (field/notify one-by-one?
                        (notify-box/pref pref:one-by-one?))
          (field/notify extra-navigation?
                        (notify-box/pref pref:extra-navigation?))
          (field/notify debug-catch-errors?
                        (notify-box/pref pref:debug-catch-errors?))
          (field/notify force-letrec-transformation?
                        (notify-box/pref pref:force-letrec-transformation?))
          (super-new)))

      (define macro-stepper-frame%
        (class base-frame%
          (init-field (filename #f))
          (init (identifier=? (pref:identifier=?)))
          (init-field (config (new macro-stepper-config%)))

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

          (define/augment (on-close)
            (send widget shutdown)
            (inner (void) on-close))

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

          (define/public (get-widget) widget)

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

          ;; FIXME: rewrite with notify-box
          (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 (send widget get-controller)
                                             on-update-identifier=?
                                             (car p)
                                             (cdr p)))))])
                          (send (send widget get-controller)
                                add-identifier=?-listener
                                (lambda (new-name new-func)
                                  (send this-choice check
                                        (eq? new-name (car p)))))))
                      (sb:identifier=-choices)))
          (when identifier=?
            (let ([p (assoc identifier=? (sb:identifier=-choices))])
              (when p
                (send (send widget get-controller)
                      on-update-identifier=?
                      (car p)
                      (cdr p)))))

          (new (get-menu-item%) (label "Clear selection") (parent stepper-menu)
               (callback
                (lambda _
                  (send (send widget get-controller) select-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))))
          (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)
          ))


      ;; macro-stepper-widget%
      (define macro-stepper-widget%
        (class* object% ()
          (init-field parent)
          (init-field config)

          ;; Terms

          ;; terms : (Cursor-of TermRecord)
          (define terms (cursor:new null))

          ;; focused-term : -> TermRecord or #f
          (define (focused-term)
            (let ([term (cursor:next terms)])
              (when term (recache term))
              term))

          ;; focused-steps : -> (Cursor-of Step) or #f
          (define/private (focused-steps)
            (let ([term (focused-term)])
              (and term 
                   (cursor? (trec-steps term))
                   (trec-steps term))))

          ;; alpha-table : module-identifier-mapping[identifier => identifier]
          (define alpha-table (make-module-identifier-mapping))

          ;; saved-position : number/#f
          (define saved-position #f)

          ;; add-deriv : Derivation -> void
          (define/public (add-deriv d)
            (let ([needs-display? (cursor:at-end? terms)])
              (for-each (lambda (id) (module-identifier-mapping-put! alpha-table id id))
                        (extract-all-fresh-names d))
              (cursor:add-to-end! terms (list (new-trec d)))
              (trim-navigator)
              (if needs-display?
                  (refresh/move)
                  (update))))

          (define/public (get-controller) sbc)
          (define/public (get-view) sbview)
          (define/public (get-macro-hiding-prefs) macro-hiding-prefs)

          (define area (new vertical-panel% (parent parent)))
          (define supernavigator
            (new horizontal-panel%
                 (parent area)
                 (stretchable-height #f)
                 (alignment '(center center))))
          (define navigator
            (new horizontal-panel%
                 (parent supernavigator)
                 (stretchable-width #f)
                 (stretchable-height #f)
                 (alignment '(left center))))
          (define extra-navigator
            (new horizontal-panel%
                 (parent supernavigator)
                 (stretchable-width #f)
                 (stretchable-height #f)
                 (alignment '(left center))
                 (style '(deleted))))

          (define sbview (new sb:syntax-widget% 
                              (parent area)
                              (macro-stepper this)
                              (pref:props-percentage pref:props-percentage)))
          (define sbc (send sbview get-controller))
          (define control-pane
            (new vertical-panel% (parent area) (stretchable-height #f)))
          (define macro-hiding-prefs
            (new macro-hiding-prefs-widget%
                 (parent control-pane)
                 (stepper this)
                 (config config)))

          (define warnings-frame #f)

          (send config listen-show-syntax-properties?
                (lambda (show?) (send sbview show-props show?)))
          (send config listen-show-hiding-panel?
                (lambda (show?) (show-macro-hiding-prefs show?)))
          (send sbc add-selection-listener
                (lambda (stx) (send macro-hiding-prefs set-syntax stx)))
          (send config listen-highlight-foci?
                (lambda (_) (update/preserve-view)))
          (send config listen-highlight-frontier?
                (lambda (_) (update/preserve-view)))
          (send config listen-show-rename-steps?
                (lambda (_) (refresh/re-reduce)))
          (send config listen-one-by-one?
                (lambda (_) (refresh/re-reduce)))
          (send config listen-force-letrec-transformation?
                (lambda (_) (refresh/resynth)))
          (send config listen-extra-navigation?
                (lambda (show?) (show-extra-navigation show?)))

          (define nav:up
            (new button% (label "Previous term") (parent navigator)
                 (callback (lambda (b e) (navigate-up)))))
          (define nav:start
            (new button% (label "<-- Start") (parent navigator)
                 (callback (lambda (b e) (navigate-to-start)))))
          (define nav:previous
            (new button% (label "<- Step") (parent navigator)
                 (callback (lambda (b e) (navigate-previous)))))
          (define nav:next
            (new button% (label "Step ->") (parent navigator)
                 (callback (lambda (b e) (navigate-next)))))
          (define nav:end
            (new button% (label "End -->") (parent navigator)
                 (callback (lambda (b e) (navigate-to-end)))))
          (define nav:down
            (new button% (label "Next term") (parent navigator)
                 (callback (lambda (b e) (navigate-down)))))

          (define/private (trim-navigator)
            (if (> (length (cursor->list terms)) 1)
                (send navigator change-children
                      (lambda _
                        (list nav:up
                              nav:start
                              nav:previous
                              nav:next
                              nav:end
                              nav:down)))
                (send navigator change-children
                      (lambda _
                        (list nav:start
                              nav:previous
                              nav:next
                              nav:end)))))

          (define/public (show-macro-hiding-prefs show?)
            (send area change-children
                  (lambda (children)
                    (if show?
                        (append (remq control-pane children) (list control-pane))
                        (remq control-pane children)))))

          (define/public (show-in-new-frame)
            (when (cursor:next terms)
              (go/deriv (trec-deriv (cursor:next terms)))))

          (define/private (show-extra-navigation show?)
            (send supernavigator change-children
                  (lambda (children)
                    (if show?
                        (list navigator extra-navigator)
                        (list navigator)))))

          ;; Navigate

          (define/private (navigate-to-start)
            (cursor:move-to-start (focused-steps))
            (update/save-position))
          (define/private (navigate-to-end)
            (cursor:move-to-end (focused-steps))
            (update/save-position))
          (define/private (navigate-previous)
            (cursor:move-prev (focused-steps))
            (update/save-position))
          (define/private (navigate-next)
            (cursor:move-next (focused-steps))
            (update/save-position))

          (define/private (navigate-up)
            (cursor:move-prev terms)
            (refresh/move))
          (define/private (navigate-down)
            (cursor:move-next terms)
            (refresh/move))

          ;; insert-step-separator : string -> void
          (define/private (insert-step-separator text)
            (send sbview add-text "\n    ")
            (send sbview add-text
                  (make-object image-snip% 
                               (build-path (collection-path "icons")
                                           "red-arrow.bmp")))
            (send sbview add-text "  ")
            (send sbview add-text text)
            (send sbview add-text "\n\n"))

          ;; insert-step-separator/small : string -> void
          (define/private (insert-step-separator/small text)
            (send sbview add-text "    ")
            (send sbview add-text
                  (make-object image-snip% 
                               (build-path (collection-path "icons")
                                           "red-arrow.bmp")))
            (send sbview add-text "  ")
            (send sbview add-text text)
            (send sbview add-text "\n\n"))

          ;; update/preserve-view : -> void
          (define/public (update/preserve-view)
            (define text (send sbview get-text))
            (define start-box (box 0))
            (define end-box (box 0))
            (send text get-visible-position-range start-box end-box)
            (update)
            (send text scroll-to-position (unbox start-box) #f (unbox end-box)))
          
          ;; update:show-prefix : -> void
          (define/private (update:show-prefix)
            ;; Show the final terms from the cached synth'd derivs
            (for-each (lambda (trec)
                        (recache trec)
                        (let ([e2 (trec-estx trec)]
                              [definites
                                (if (pair? (trec-definites trec))
                                    (trec-definites trec)
                                    null)])
                          (if e2
                              (send sbview add-syntax e2
                                    #:alpha-table alpha-table
                                    #:definites definites)
                              (send sbview add-text "Error\n"))))
                      (cursor:prefix->list terms)))

          ;; update:show-current-step : -> void
          (define/private (update:show-current-step)
            (define steps (focused-steps))
            (when (focused-term)
              (when steps
                (let ([step (cursor:next steps)])
                  (cond [(step? step)
                         (update:show-step step)]
                        [(misstep? step)
                         (update:show-misstep step)]
                        [(prestep? step)
                         (update:show-prestep step)]
                        [(poststep? step)
                         (update:show-poststep step)]
                        [(not step)
                         (update:show-final (focused-term))])))
              (unless steps
                (send sbview add-text
                      "Internal error computing reductions. Original term:\n")
                (send sbview add-syntax
                      (lift/deriv-e1 (trec-deriv (focused-term))))
                #;(print-struct #t)
                #;(send sbview add-text (format "~s~n" (focused-term))))))

          ;; update:show-lctx : Step -> void
          (define/private (update:show-lctx step)
            (define lctx (protostep-lctx step))
            (when (pair? lctx)
              (send sbview add-text "\n")
              (for-each (lambda (bf)
                          (send sbview add-text 
                                "while executing macro transformer in:\n")
                          (insert-syntax/redex (bigframe-term bf)
                                               (bigframe-foci bf)
                                               (protostep-definites step)
                                               (protostep-frontier step)))
                        (reverse lctx))))

          ;; update:separator : Step -> void
          (define/private (update:separator step)
            (insert-step-separator (step-type->string (protostep-type step))))

          ;; update:separator/small : Step -> void
          (define/private (update:separator/small step)
            (insert-step-separator/small
             (step-type->string (protostep-type step))))
          
          ;; update:show-step : Step -> void
          (define/private (update:show-step step)
            (insert-syntax/redex (step-term1 step)
                                 (step-foci1 step)
                                 (protostep-definites step)
                                 (protostep-frontier step))
            (update:separator step)
            (insert-syntax/contractum (step-term2 step)
                                      (step-foci2 step)
                                      (protostep-definites step)
                                      (protostep-frontier step))
            (update:show-lctx step))

          ;; update:show-prestep : Step -> void
          (define/private (update:show-prestep step)
            (update:separator/small step)
            (insert-syntax/redex (prestep-term1 step)
                                 (prestep-foci1 step)
                                 (protostep-definites step)
                                 (protostep-frontier step))
            (update:show-lctx step))

          ;; update:show-poststep : Step -> void
          (define/private (update:show-poststep step)
            (update:separator/small step)
            (insert-syntax/contractum (poststep-term2 step)
                                      (poststep-foci2 step)
                                      (protostep-definites step)
                                      (protostep-frontier step))
            (update:show-lctx step))

          ;; update:show-misstep : Step -> void
          (define/private (update:show-misstep step)
            (insert-syntax/redex (misstep-term1 step)
                                 (misstep-foci1 step)
                                 (protostep-definites step)
                                 (protostep-frontier step))
            (update:separator step)
            (send sbview add-text (exn-message (misstep-exn step)))
            (send sbview add-text "\n")
            (when (exn:fail:syntax? (misstep-exn step))
              (for-each (lambda (e) (send sbview add-syntax e
                                          #:alpha-table alpha-table
                                          #:definites (protostep-definites step)))
                        (exn:fail:syntax-exprs (misstep-exn step))))
            (update:show-lctx step))

          ;; update:show-final : TermRecord -> void
          (define/private (update:show-final trec)
            (define result (trec-estx trec))
            (when result
              (send sbview add-text "Expansion finished\n")
              (send sbview add-syntax result
                    #:alpha-table alpha-table
                    #:definites (let ([definites (trec-definites trec)])
                                  (if (pair? definites) definites null))))
            (unless result
              (send sbview add-text "Error\n")))

          ;; update:show-suffix : -> void
          (define/private (update:show-suffix)
            (let ([suffix0 (cursor:suffix->list terms)])
              (when (pair? suffix0)
                (for-each (lambda (trec)
                            (send sbview add-syntax
                                  (lift/deriv-e1 (trec-deriv trec))
                                  #:alpha-table alpha-table))
                          (cdr suffix0)))))

          ;; update/save-position : -> void
          (define/private (update/save-position)
            (save-position)
            (update))

          ;; update : -> void
          ;; Updates the terms in the syntax browser to the current step
          (define/private (update)
            (define text (send sbview get-text))
            (define position-of-interest 0)
            (send text begin-edit-sequence)
            (send sbview erase-all)

            (update:show-prefix)
            (send sbview add-separator)
            (set! position-of-interest (send text last-position))
            (update:show-current-step)
            (send sbview add-separator)
            (update:show-suffix)
            (send text end-edit-sequence)
            (send text scroll-to-position
                  position-of-interest
                  #f
                  (send text last-position)
                  'start)
            (enable/disable-buttons))

          ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
          (define/private (insert-syntax/color stx foci definites frontier hi-color)
            (send sbview add-syntax stx
                  #:definites definites
                  #:alpha-table alpha-table
                  #:hi-color hi-color
                  #:hi-stxs (if (send config get-highlight-foci?) foci null)
                  #:hi2-color "WhiteSmoke"
                  #:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))

          ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
          (define/private (insert-syntax/redex stx foci definites frontier)
            (insert-syntax/color stx foci definites frontier "MistyRose"))

          ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
          (define/private (insert-syntax/contractum stx foci definites frontier)
            (insert-syntax/color stx foci definites frontier "LightCyan"))

          ;; enable/disable-buttons : -> void
          (define/private (enable/disable-buttons)
            (define steps (focused-steps))
            (send nav:start enable (and steps (cursor:has-prev? steps)))
            (send nav:previous enable (and steps (cursor:has-prev? steps)))
            (send nav:next enable (and steps (cursor:has-next? steps)))
            (send nav:end enable (and steps (cursor:has-next? steps)))
            (send nav:up enable (cursor:has-prev? terms))
            (send nav:down enable (cursor:has-next? terms)))

          ;; --

          ;; refresh/resynth : -> void
          ;; Macro hiding policy has changed; invalidate cached parts of trec
          (define/public (refresh/resynth)
            (for-each trec:invalidate-synth! (cursor->list terms))
            (refresh))

          ;; refresh/re-reduce : -> void
          ;; Reduction config has changed; invalidate cached parts of trec
          (define/private (refresh/re-reduce)
            (for-each trec:invalidate-steps! (cursor->list terms))
            (refresh))

          ;; refresh/move : -> void
          ;; Moving between terms; clear the saved position
          (define/private (refresh/move)
            (clear-saved-position)
            (refresh))

          ;; refresh : -> void
          (define/public (refresh)
            (restore-position)
            (update))

          ;; recache : TermRecord -> void
          (define/private (recache trec)
            (unless (trec-synth-deriv trec)
              (with-handlers ([(lambda (e) #t)
                               (lambda (e)
                                 (handle-recache-error e 'macro-hiding)
                                 (set-trec-synth-deriv! trec 'error)
                                 (set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))])
                (let-values ([(synth-deriv estx) (synthesize (trec-deriv trec))])
                  (set-trec-synth-deriv! trec synth-deriv)
                  (set-trec-estx! trec estx))))
            (unless (trec-raw-steps trec)
              (with-handlers ([(lambda (e) #t)
                               (lambda (e)
                                 (handle-recache-error e 'reductions)
                                 (set-trec-raw-steps! trec 'error)
                                 (set-trec-definites! trec 'error))])
                (let-values ([(steps definites)
                              (reductions+definites
                               (or (trec-synth-deriv trec) (trec-deriv trec)))])
                  (set-trec-raw-steps! trec steps)
                  (set-trec-definites! trec definites))))
            (unless (trec-steps trec)
              (with-handlers ([(lambda (e) #t)
                               (lambda (e)
                                 (handle-recache-error e 'special-reductions)
                                 (set-trec-steps! trec 'error))])
                (set-trec-steps!
                 trec
                 (let ([raw-steps (trec-raw-steps trec)])
                   (if (eq? raw-steps 'error)
                       'error
                       (let ([filtered-steps 
                              (if (send config get-show-rename-steps?)
                                  raw-steps
                                  (filter (lambda (x) (not (rename-step? x))) raw-steps))])
                         (cursor:new
                          (if (send config get-one-by-one?)
                              (reduce:one-by-one filtered-steps)
                              filtered-steps)))))))))

          ;; delayed-recache-errors : (list-of (cons exn string))
          (define delayed-recache-errors null)

          ;; handle-recache-error : exception string -> void
          (define/private (handle-recache-error exn part)
            (if (pref:debug-catch-errors?)
                (begin
                  (set! delayed-recache-errors 
                        (cons (cons exn part) delayed-recache-errors))
                  (queue-callback
                   (lambda ()
                     (when (pair? delayed-recache-errors)
                       (message-box
                        "Error"
                        (string-append 
                         "Internal errors in macro stepper:\n"
                         (if (memq 'macro-hiding (map cdr delayed-recache-errors))
                             (string-append 
                              "Macro hiding failed on one or more terms. "
                              "The macro stepper is showing the terms "
                              "with macro hiding disabled.\n")
                             "")
                         (if (memq 'reductions (map cdr delayed-recache-errors))
                             (string-append
                              "The macro stepper failed to compute the reduction sequence "
                              "for one or more terms.\n")
                             "")))
                       (set! delayed-recache-errors null)))))
                (raise exn)))

          ;; update-saved-position : num -> void
          (define/private (update-saved-position pos)
            (when pos (set! saved-position pos)))

          ;; clear-saved-position : -> void
          (define/private (clear-saved-position)
            (set! saved-position #f))

          ;; save-position : -> void
          (define/private (save-position)
            (when (cursor? (focused-steps))
              (let ([step (cursor:next (focused-steps))])
                (cond [(not step)
                       ;; At end; go to the end when restored
                       (update-saved-position +inf.0)]
                      [(protostep? step)
                       (update-saved-position
                        (extract-protostep-seq step))]))))

          ;; restore-position : number -> void
          (define/private (restore-position)
            (define steps (focused-steps))
            (define (advance)
              (let ([step (cursor:next steps)])
                (cond [(not step)
                       ;; At end; stop
                       (void)]
                      [(protostep? step)
                       (let ([step-pos (extract-protostep-seq step)])
                         (cond [(not step-pos)
                                (cursor:move-next steps)
                                (advance)]
                               [(< step-pos saved-position)
                                (cursor:move-next steps)
                                (advance)]
                               [else (void)]))])))
            (when saved-position
              (when steps
                (advance))))

          (define/private (extract-protostep-seq step)
            (match (protostep-deriv step)
              [(AnyQ mrule (_ _ (AnyQ transformation (_ _ _ _ _ _ seq)) _))
               seq]
              [else #f]))

          ;; synthesize : Derivation -> Derivation Syntax
          (define/private (synthesize deriv)
            (let ([show-macro? (get-show-macro?)])
              (if show-macro?
                  (parameterize ((current-hiding-warning-handler
                                  (lambda (tag message)
                                    (unless (send config get-suppress-warnings?)
                                      (unless warnings-frame
                                        (set! warnings-frame (new warnings-frame%)))
                                      (send warnings-frame add-warning tag message)
                                      (send warnings-frame show #t))))
                                 (force-letrec-transformation
                                  (send config get-force-letrec-transformation?)))
                    (hide/policy deriv show-macro?))
                  (values deriv (lift/deriv-e2 deriv)))))

          (define/private (reduce:one-by-one rs)
            (let loop ([rs rs])
              (match rs
                [(cons (struct step (d l t c df fr redex contractum e1 e2)) rs)
                 (list* (make-prestep d l "Find redex" c df fr redex e1)
                        (make-poststep d l t c df fr contractum e2)
                        (loop rs))]
                [(cons (struct misstep (d l t c df fr redex e1 exn)) rs)
                 (list* (make-prestep d l "Find redex" c df fr redex e1)
                        (make-misstep d l t c df fr redex e1 exn)
                        (loop rs))]
                ['()
                 null])))

          (define/private (foci x) (if (list? x) x (list x)))

          ;; Hiding policy

          (define/private (get-show-macro?)
            (and (send config get-macro-hiding?)
                 (send macro-hiding-prefs get-show-macro?)))

          ;; --

          (define/public (shutdown)
            (when warnings-frame (send warnings-frame show #f)))

          ;; Initialization
          
          (super-new)
          (send sbview show-props (send config get-show-syntax-properties?))
          (show-macro-hiding-prefs (send config get-show-hiding-panel?))
          (show-extra-navigation (send config get-extra-navigation?))
          (refresh/move)
          ))

      ;; Main entry points

      (define (make-macro-stepper)
        (let ([f (new macro-stepper-frame%)])
          (send f show #t)
          (send f get-widget)))

      (define (go stx)
        (let ([stepper (make-macro-stepper)])
          (send stepper add-deriv (trace stx))))

      (define (go/deriv deriv)
        (let* ([f (new macro-stepper-frame%)]
               [w (send f get-widget)])
          (send w add-deriv deriv)
          (send f show #t)
          w))

      ))
  
  ;; Extensions
  
  (define keymap-extension@
    (unit
      (import (prefix pre: sb:keymap^))
      (export sb:keymap^)
      
      (define syntax-keymap%
        (class pre:syntax-keymap%
          (init-field macro-stepper)
          (inherit-field controller)
          (inherit add-function)
          
          (super-new)
          
          (define/public (get-hiding-panel)
            (send macro-stepper get-macro-hiding-prefs))
          
          (add-function "hiding:show-macro"
                        (lambda (i e)
                          (send* (get-hiding-panel)
                            (add-show-identifier)
                            (refresh))))
          
          (add-function "hiding:hide-macro"
                        (lambda (i e)
                          (send* (get-hiding-panel)
                            (add-hide-identifier)
                            (refresh))))))))
  
  (define context-menu-extension@
    (unit
      (import (prefix pre: sb:context-menu^))
      (export sb:context-menu^)
      
      (define context-menu%
        (class pre:context-menu%
          (inherit-field keymap)
          (inherit add-separator)
          
          (field [show-macro #f]
                 [hide-macro #f])
          
          (define/override (after-selection-items)
            (super after-selection-items)
            (add-separator)
            (set! show-macro
                  (new menu-item% (label "Show this macro") (parent this)
                       (callback (lambda (i e)
                                   (send keymap call-function "hiding:show-macro" i e)))))
            (set! hide-macro
                  (new menu-item% (label "Hide this macro") (parent this)
                       (callback (lambda (i e)
                                   (send keymap call-function "hiding:hide-macro" i e)))))
            (void))
          
          (define/override (on-demand)
            (define hiding-panel (send keymap get-hiding-panel))
            (define controller (send keymap get-controller))
            (define stx (send controller get-selected-syntax))
            (define id? (identifier? stx))
            (define show-macro? (send hiding-panel get-show-macro?))
            (define transparent? (and id? (show-macro? stx)))
            (define opaque? (and id? (not (show-macro? stx))))
            (send show-macro enable (and id? (not transparent?)))
            (send hide-macro enable (and id? (not opaque?)))
            (super on-demand))

          (super-new)))))
  
  (define browser-extension@
    (unit
      (import (prefix pre: sb:widget^)
              sb:keymap^)
      (export sb:widget^)
      
      (define syntax-widget%
        (class pre:syntax-widget%
          (init-field macro-stepper)
          
          (define/override (make-keymap text)
            (new syntax-keymap%
                 (editor text)
                 (widget this)
                 (macro-stepper macro-stepper)))

          (define/override (show-props show?)
            (super show-props show?)
            (send macro-stepper update/preserve-view))

          (super-new)))))
  
  ;; Linking
  
  (define context-menu@
    (compound-unit
      (import)
      (link [((SB:MENU : sb:context-menu^)) sb:widget-context-menu@]
            [((V:MENU : sb:context-menu^)) context-menu-extension@ SB:MENU])
      (export V:MENU)))
  
  (define keymap@
    (compound-unit
      (import [MENU : sb:context-menu^]
              [SNIP : sb:snip^])
      (link [((SB:KEYMAP : sb:keymap^)) sb:widget-keymap@ MENU SNIP]
            [((V:KEYMAP : sb:keymap^)) keymap-extension@ SB:KEYMAP])
      (export V:KEYMAP)))

  (define widget@
    (compound-unit
      (import [KEYMAP : sb:keymap^])
      (link [((SB:WIDGET : sb:widget^)) sb:widget@ KEYMAP]
            [((V:WIDGET : sb:widget^)) browser-extension@ SB:WIDGET KEYMAP])
      (export V:WIDGET)))
  
  (define pre-stepper@
    (compound-unit
      (import [BASE : view-base^])
      (link [((PREFS : prefs^)) prefs@]
            [((MENU : sb:context-menu^)) context-menu@]
            [((KEYMAP : sb:keymap^)) keymap@ MENU SNIP]
            [((SNIP : sb:snip^)) sb:global-snip@]
            [((WIDGET : sb:widget^)) widget@ KEYMAP]
            [((VIEW : view^)) view@ PREFS BASE WIDGET])
      (export VIEW)))

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