#reader scribble/reader
#lang scheme/base

(provide
 (struct-out generic)
 
 (struct-out generic/docs)
 
 (struct-out generic-override)
 (struct-out generic-augment)
 (struct-out generic-method)
 (struct-out generic-private-field)
 
 (struct-out menu-item)
 menu-name->get-menu-name ;; : menu-item -> symbol
 
 (struct-out before/after)
 (struct-out before)
 (struct-out after)
 
 (struct-out between)
 
 (struct-out an-item)
 (struct-out a-checkable-item)
 (struct-out a-submenu-item) 
 
 ;; an-item -> symbol
 ;; calcualates the names of various identifiers associated with the item.
 an-item->callback-name
 an-item->create-menu-item-name
 an-item->get-item-name
 an-item->item-name
 an-item->on-demand-name
 an-item->string-name
 an-item->help-string-name
 
 before/after->name
 between->name
 
 items)

(define-struct generic (name initializer))
(define-struct (generic/docs generic) (documentation))
(define-struct (generic-override generic/docs) ())
(define-struct (generic-augment generic/docs) ())
(define-struct (generic-method generic/docs) ())
(define-struct (generic-private-field generic) ())

(define-struct menu-item (menu-name))
(define (menu-name->get-menu-name menu-item)
  (string->symbol
   (format "get-~a" (menu-item-menu-name menu-item))))

(define-struct (before/after menu-item) (name procedure))
(define-struct (before before/after) ())
(define-struct (after before/after) ())
(define (before/after->name before/after)
  (string->symbol (format "~a:~a-~a"
                          (menu-item-menu-name before/after)
                          (if (before? before/after)
                              "before"
                              "after")
                          (before/after-name before/after))))

(define-struct (between menu-item) (before after procedure))
(define (between->name between)
  (string->symbol (format "~a:between-~a-and-~a"
                          (menu-item-menu-name between)
                          (between-before between)
                          (between-after between))))

(define-struct (an-item menu-item)
  (item-name
   help-string
   proc
   shortcut
   shortcut-prefix
   menu-string
   on-demand
   create))
(define-struct (a-submenu-item an-item) ())
(define-struct (a-checkable-item an-item) ())

(define (an-item->callback-name item)
  (string->symbol
   (format "~a:~a-callback" (menu-item-menu-name item) (an-item-item-name item))))
(define (an-item->create-menu-item-name item)
  (string->symbol
   (format "~a:create-~a?" (menu-item-menu-name item) (an-item-item-name item))))
(define (an-item->get-item-name item)
  (string->symbol
   (format "~a:get-~a-item" (menu-item-menu-name item) (an-item-item-name item))))
(define (an-item->item-name item)
  (string->symbol
   (format "~a:~a-item" (menu-item-menu-name item) (an-item-item-name item))))
(define (an-item->on-demand-name item)
  (string->symbol
   (format "~a:~a-on-demand" (menu-item-menu-name item) (an-item-item-name item))))
(define (an-item->string-name item)
  (string->symbol
   (format "~a:~a-string" (menu-item-menu-name item) (an-item-item-name item))))
(define (an-item->help-string-name item)
  (string->symbol
   (format "~a:~a-help-string" (menu-item-menu-name item) (an-item-item-name item))))

(define (edit-menu:do const)
  `(λ (menu evt)
     (let ([edit (get-edit-target-object)])
       (when (and edit
                  (is-a? edit editor<%>))
         (send edit do-edit-operation ',const)))
     #t))

(define (edit-menu:can-do-on-demand const)
  `(λ (item)
     (let* ([editor (get-edit-target-object)]
            [enable?
             (and editor
                  (is-a? editor editor<%>)
                  (send editor can-do-edit-operation? ',const))])
       (send item enable enable?))))

(define edit-menu:edit-target-on-demand
  `(λ (item)
     (send item enable
           (let ([target (get-edit-target-object)])
             (and target (is-a? target editor<%>))))))

(define on-demand-do-nothing '(λ (menu-item) (void)))

(define items
  (list (make-generic-augment
         'on-close
         '(λ ()
            (remove-prefs-callback)
            (inner (void) on-close))
         (list
          '@defmethod[(on-close) void?]{
             Removes the preferences callbacks for the menu items
           }))
        (make-generic-method 
         'get-menu% '(λ () menu:can-restore-underscore-menu%)
         (list
          '@defmethod[(get-menu%) 
                      (is-a?/c menu:can-restore-underscore-menu%)]{
             The result of this method is used as the class
                 for creating the result of these methods:
                 @method[frame:standard-menus get-file-menu],
                 @method[frame:standard-menus get-edit-menu], and
                 @method[frame:standard-menus get-help-menu].}))
        (make-generic-method 
         'get-menu-item% '(λ () menu:can-restore-menu-item%)
         (list
          '@defmethod[(get-menu-item%) (is-a?/c menu:can-restore-menu-item%)]{
             The result of this method is used as the class for creating
             the menu items in this frame.

             Defaultly returns @scheme[menu:can-restore-menu-item].}))
        (make-generic-method 
         'get-checkable-menu-item% '(λ () menu:can-restore-checkable-menu-item%)
         (list
          '@defmethod[(get-checkable-menu-item%) (is-a?/c menu:can-restore-checkable-menu-item%)]{
             The result of this method is used as the class for creating
             checkable menu items in this class.

             Defaultly returns @scheme[menu:can-restore-checkable-menu-item].}))
        
        (make-generic-method 
         'get-file-menu
         '(λ () file-menu)
         (list
          '@defmethod[(get-file-menu) (is-a?/c menu%)]{
             Returns the file menu.
             See also @method[frame:standard-menus<%> get-menu%].}))
        
        (make-generic-private-field 
         'file-menu
         '(make-object (get-menu%)
            (string-constant file-menu-label)
            (get-menu-bar)))
        (make-generic-method
         'get-edit-menu
         '(λ () edit-menu)
         (list
          '@defmethod[(get-edit-menu) (is-a?/c menu%)]{
             Returns the edit menu.
             See also @method[frame:standard-menus<%> get-menu%].}))
        (make-generic-private-field 
         'edit-menu
         '(make-object (get-menu%) (string-constant edit-menu-label) (get-menu-bar)))
        (make-generic-method
         'get-help-menu
         '(λ () help-menu)
         (list
          '@defmethod[(get-help-menu) (is-a?/c menu%)]{
             Returns the help menu.
             See also @method[frame:standard-menus<%> get-menu%].}))
        (make-generic-private-field
         'help-menu
         '(make-object (get-menu%) (string-constant help-menu-label) (get-menu-bar)))
        
        (make-an-item 'file-menu 'new 
                      '(string-constant new-info)
                      '(λ (item control) (handler:edit-file #f) #t)
                      #\n
                      '(get-default-shortcut-prefix)
                      '(string-constant new-menu-item)
                      on-demand-do-nothing
                      #t)
        (make-between 'file-menu 'new 'open 'nothing)
        (make-an-item 'file-menu 'open '(string-constant open-info)
                      '(λ (item control) (handler:open-file) #t)
                      #\o
                      '(get-default-shortcut-prefix)
                      '(string-constant open-menu-item)
                      on-demand-do-nothing
                      #t)
        (make-a-submenu-item 'file-menu 'open-recent 
                             '(string-constant open-recent-info)
                             '(λ (x y) (void))
                             #f
                             '(get-default-shortcut-prefix)
                             '(string-constant open-recent-menu-item)
                             '(λ (menu)
                                (handler:install-recent-items menu))
                             #t)
        (make-between 'file-menu 'open 'revert 'nothing)
        (make-an-item 'file-menu 'revert 
                      '(string-constant revert-info)
                      '(λ (item control) (void))
                      #f
                      '(get-default-shortcut-prefix)
                      '(string-constant revert-menu-item)
                      on-demand-do-nothing
                      #f)
        (make-between 'file-menu 'revert 'save 'nothing)
        (make-an-item 'file-menu 'save
                      '(string-constant save-info)
                      '(λ (item control) (void))
                      #\s
                      '(get-default-shortcut-prefix)
                      '(string-constant save-menu-item)
                      on-demand-do-nothing
                      #f)
        (make-an-item 'file-menu 'save-as
                      '(string-constant save-as-info)
                      '(λ (item control) (void))
                      #f
                      '(get-default-shortcut-prefix)
                      '(string-constant save-as-menu-item)
                      on-demand-do-nothing
                      #f)
        (make-between 'file-menu 'save-as 'print 'nothing)
        (make-an-item 'file-menu 'print
                      '(string-constant print-info)
                      '(λ (item control) (void))
                      #\p
                      '(get-default-shortcut-prefix)
                      '(string-constant print-menu-item)
                      on-demand-do-nothing
                      #f)
        (make-between 'file-menu 'print 'close 'separator)
        (make-an-item 'file-menu 'close
                      '(string-constant close-info)
                      '(λ (item control) (when (can-close?) (on-close) (show #f)) #t)
                      #\w
                      '(get-default-shortcut-prefix)
                      '(string-constant close-menu-item)
                      on-demand-do-nothing
                      #t)
        (make-between 'file-menu 'close 'quit 'nothing)
        (make-an-item 'file-menu 'quit
                      '(string-constant quit-info)
                      '(λ (item control) 
                         (when (exit:user-oks-exit)
                           (exit:exit)))
                      #\q
                      '(get-default-shortcut-prefix)
                      '(if (eq? (system-type) 'windows) 
                           (string-constant quit-menu-item-windows)
                           (string-constant quit-menu-item-others))
                      on-demand-do-nothing
                      '(not (current-eventspace-has-standard-menus?)))
        (make-after 'file-menu 'quit 'nothing)
        
        (make-an-item 'edit-menu 'undo 
                      '(string-constant undo-info)
                      (edit-menu:do  'undo)
                      #\z
                      '(get-default-shortcut-prefix)
                      '(string-constant undo-menu-item)
                      (edit-menu:can-do-on-demand 'undo)
                      #t)
        (make-an-item 'edit-menu 'redo 
                      '(string-constant redo-info)
                      (edit-menu:do 'redo)
                      '(if (eq? (system-type) 'windows)
                           #\y
                           #\z)
                      '(if (eq? (system-type) 'windows)
                           (get-default-shortcut-prefix)
                           (cons 'shift (get-default-shortcut-prefix)))
                      '(string-constant redo-menu-item)
                      (edit-menu:can-do-on-demand 'redo)
                      #t)
        (make-between 'edit-menu 'redo 'cut 'separator)
        (make-an-item 'edit-menu 'cut '(string-constant cut-info)
                      (edit-menu:do 'cut)
                      #\x
                      '(get-default-shortcut-prefix)
                      '(string-constant cut-menu-item)
                      (edit-menu:can-do-on-demand 'cut)
                      #t)
        (make-between 'edit-menu 'cut 'copy 'nothing)
        (make-an-item 'edit-menu 'copy 
                      '(string-constant copy-info)
                      (edit-menu:do 'copy)
                      #\c
                      '(get-default-shortcut-prefix)
                      '(string-constant copy-menu-item)
                      (edit-menu:can-do-on-demand 'copy)
                      #t)
        (make-between 'edit-menu 'copy 'paste 'nothing)
        (make-an-item 'edit-menu 'paste 
                      '(string-constant paste-info)
                      (edit-menu:do 'paste)
                      #\v
                      '(get-default-shortcut-prefix)
                      '(string-constant paste-menu-item)
                      (edit-menu:can-do-on-demand 'paste)
                      #t)
        (make-between 'edit-menu 'paste 'clear 'nothing)
        (make-an-item 'edit-menu 'clear 
                      '(string-constant clear-info)
                      (edit-menu:do 'clear)
                      #f
                      '(get-default-shortcut-prefix)
                      '(if (eq? (system-type) 'windows)
                           (string-constant clear-menu-item-windows)
                           (string-constant clear-menu-item-windows))
                      (edit-menu:can-do-on-demand 'clear)
                      #t)
        (make-between 'edit-menu 'clear 'select-all 'nothing)
        (make-an-item 'edit-menu 'select-all
                      '(string-constant select-all-info)
                      (edit-menu:do 'select-all)
                      #\a
                      '(get-default-shortcut-prefix)
                      '(string-constant select-all-menu-item)
                      (edit-menu:can-do-on-demand 'select-all)
                      #t)
        (make-between 'edit-menu 'select-all 'find 'separator)
        
        (make-an-item 'edit-menu 'find  
                      '(string-constant find-info)
                      '(λ (item control) (void))
                      #\f
                      '(get-default-shortcut-prefix)
                      '(string-constant find-menu-item)
                      edit-menu:edit-target-on-demand
                      #f)
        
        (make-an-item 'edit-menu 'find-next
                      '(string-constant find-next-info)
                      '(λ (item control) (void))
                      #\g
                      '(get-default-shortcut-prefix)
                      '(string-constant find-next-menu-item)
                      edit-menu:edit-target-on-demand
                      #f)
        (make-an-item 'edit-menu 'find-previous
                      '(string-constant find-previous-info)
                      '(λ (item control) (void))
                      #\g
                      '(cons 'shift (get-default-shortcut-prefix))
                      '(string-constant find-previous-menu-item)
                      edit-menu:edit-target-on-demand
                      #f)
        (make-an-item 'edit-menu 'show/hide-replace
                      '(string-constant show/hide-replace-info)
                      '(λ (item control) (void))
                      #\r
                      '(cons 'shift (get-default-shortcut-prefix))
                      '(string-constant show-replace-menu-item)
                      on-demand-do-nothing
                      #f)
        (make-an-item 'edit-menu 'replace
                      '(string-constant replace-info)
                      '(λ (item control) (void))
                      #\r
                      '(get-default-shortcut-prefix)
                      '(string-constant replace-menu-item)
                      on-demand-do-nothing
                      #f)
        (make-an-item 'edit-menu 'replace-all 
                      '(string-constant replace-all-info)
                      '(λ (item control) (void))
                      #f
                      '(get-default-shortcut-prefix)
                      '(string-constant replace-all-menu-item)
                      on-demand-do-nothing
                      #f)

        (make-a-checkable-item 'edit-menu 'find-case-sensitive
                               '(string-constant find-case-sensitive-info)
                               '(λ (item control) (void))
                               #f
                               '(get-default-shortcut-prefix)
                               '(string-constant find-case-sensitive-menu-item)
                               edit-menu:edit-target-on-demand
                               #f)
        
        (make-between 'edit-menu 'find 'preferences 'nothing-with-standard-menus)
        (make-an-item 'edit-menu 'preferences 
                      '(string-constant preferences-info)
                      '(λ (item control) (preferences:show-dialog) #t)
                      '(case (system-type)
                         [(macosx) #\,]
                         [else #\;])
                      '(get-default-shortcut-prefix)
                      '(string-constant preferences-menu-item)
                      on-demand-do-nothing
                      '(not (current-eventspace-has-standard-menus?)))
        (make-after 'edit-menu 'preferences 'nothing)
        
        (make-before 'help-menu 'about 'nothing)
        (make-an-item 'help-menu 'about 
                      '(string-constant about-info)
                      '(λ (item control) (void))
                      #f
                      '(get-default-shortcut-prefix)
                      '(string-constant about-menu-item)
                      on-demand-do-nothing
                      #f)
        (make-after 'help-menu 'about 'nothing)))