#lang scheme/base
(require scheme/class
         scheme/gui
         scheme/list
         syntax/boundmap
         "../model/hiding-policies.ss"
         "../util/mpi.ss"
         "../util/notify.ss")
(provide macro-hiding-prefs-widget%)

(define mode:disable "Disable")
(define mode:standard "Standard")
(define mode:custom "Custom ...")

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

    (define/public (get-policy)
      (let ([mode (get-mode)])
        (cond [(not (macro-hiding-enabled?)) #f]
              [(equal? mode mode:standard) standard-policy]
              [(equal? mode mode:custom) (get-custom-policy)])))

    (define/private (get-custom-policy)
      (let ([hide-mzscheme? (send box:hide-mzscheme get-value)]
            [hide-libs? (send box:hide-libs get-value)]
            [hide-contracts? (send box:hide-contracts get-value)]
            [hide-transformers? (send box:hide-phase1 get-value)]
            [specialized-policies (get-specialized-policies)])
        (make-policy hide-mzscheme?
                     hide-libs?
                     hide-contracts?
                     hide-transformers?
                     specialized-policies)))

    (define super-panel
      (new vertical-panel%
           (parent parent)
           (stretchable-height #f)))
    (define top-line-panel
      (new horizontal-panel%
           (parent super-panel)
           (alignment '(left center))
           (stretchable-height #f)))
    (define customize-panel
      (new horizontal-panel%
           (parent super-panel)
           (stretchable-height #f)
           (alignment '(left top))
           (style '(deleted))))
    (define left-pane
      (new vertical-pane%
           (parent customize-panel)
           (stretchable-width #f)
           (alignment '(left top))))
    (define right-pane
      (new vertical-pane%
           (parent customize-panel)))

    (define mode-selector
      (choice/notify-box
       top-line-panel
       "Macro hiding: "
       (list mode:disable mode:standard mode:custom)
       (get-field macro-hiding-mode config)))
    (define top-line-inner-panel
      (new horizontal-panel%
           (parent top-line-panel)
           (alignment '(right center))
           (style '(deleted))))

    (define/private (get-mode)
      (send config get-macro-hiding-mode))

    (define/private (macro-hiding-enabled?)
      (let ([mode (get-mode)])
        (or (equal? mode mode:standard)
            (and (equal? mode mode:custom)
                 (send box:hiding get-value)))))

    (define/private (ensure-custom-mode)
      (unless (equal? (get-mode) mode:custom)
        (send config set-macro-hiding-mode mode:custom)))

    (define/private (update-visibility)
      (let ([customizing (equal? (get-mode) mode:custom)])
        (send top-line-panel change-children
              (lambda (children)
                (append (remq top-line-inner-panel children)
                        (if customizing (list top-line-inner-panel) null))))
        (send super-panel change-children
              (lambda (children)
                (append (remq customize-panel children)
                        (if (and customizing (send box:edit get-value))
                            (list customize-panel)
                            null))))))

    (send config listen-macro-hiding-mode
          (lambda (value)
            (update-visibility)
            (force-refresh)))

    (define box:hiding
      (new check-box%
           (label "Enable macro hiding")
           (value #t)
           (parent top-line-inner-panel)
           (callback (lambda (c e) (force-refresh)))))
    (define box:edit
      (new check-box%
           (label "Show policy editor")
           (parent top-line-inner-panel)
           (value #t)
           (callback (lambda (c e) (update-visibility)))))

    (define box:hide-mzscheme
      (new check-box%
           (label "Hide mzscheme syntax")
           (parent left-pane)
           (value #t)
           (callback (lambda (c e) (refresh)))))
    (define box:hide-libs
      (new check-box%
           (label "Hide library syntax")
           (parent left-pane)
           (value #t)
           (callback (lambda (c e) (refresh)))))
    (define box:hide-contracts
      (new check-box%
           (label "Hide contracts (heuristic)")
           (parent left-pane)
           (value #t)
           (callback (lambda (c e) (refresh)))))
    (define box:hide-phase1
      (new check-box%
           (label "Hide phase>0")
           (parent left-pane)
           (value #t)
           (callback (lambda (c e) (refresh)))))

    (define look-ctl
      (new list-box% (parent right-pane) (label "")
           (choices null) (style '(extended))
           (callback
            (lambda (c e)
              (send delete-ctl enable (pair? (send c get-selections)))))))

    (define look-button-pane
      (new horizontal-pane% (parent right-pane) (stretchable-width #f)))

    (define delete-ctl
      (new button% (parent look-button-pane) (label "Delete rule") (enabled #f)
           (callback (lambda _ (delete-selected) (refresh)))))
    (define add-hide-id-button
      (new button% (parent look-button-pane) (label "Hide macro") (enabled #f)
           (callback (lambda _ (add-hide-identifier) (refresh)))))
    (define add-show-id-button
      (new button% (parent look-button-pane) (label "Show macro") (enabled #f)
           (callback (lambda _ (add-show-identifier) (refresh)))))
    #;(new grow-box-spacer-pane% (parent right-pane))

    ;; Methods

    (define stx #f)
    (define stx-name #f)

    ;; refresh : -> void
    (define/public (refresh)
      (when (macro-hiding-enabled?)
        (send stepper refresh/resynth)))

    ;; force-refresh : -> void
    (define/private (force-refresh)
      (send stepper refresh/resynth))

    ;; set-syntax : syntax/#f -> void
    (define/public (set-syntax lstx)
      (set! stx (and (identifier? lstx) lstx))
      (when (identifier? stx)
        (let ([binding (identifier-binding stx)])
          (if (pair? binding)
              (set! stx-name (cadr binding))
              (set! stx-name (syntax-e stx)))))
      (send add-show-id-button enable (identifier? lstx))
      (send add-hide-id-button enable (identifier? lstx)))

    (define identifier-policies null)

    (define/private (get-specialized-policies)
      (map (lambda (policy)
             (define key (mcar policy))
             (define show? (mcdr policy))
             (cond [(pair? key)
                    (lambda (id binding return)
                      (when (and (pair? binding)
                                 (equal? key (get-id-key/binding id binding)))
                        (return show?)))]
                   [else
                    (lambda (id binding return)
                      (when (free-identifier=? id key)
                        (return show?)))]))
           identifier-policies))

    (define/public (add-hide-identifier)
      (add-identifier-policy #f)
      (ensure-custom-mode))

    (define/public (add-show-identifier)
      (add-identifier-policy #t)
      (ensure-custom-mode))

    (define/private (add-identifier-policy show?)
      (when (identifier? stx)
        (let ([key (get-id-key stx)])
          (let loop ([i 0] [policies identifier-policies])
            (cond [(null? policies)
                   (set! identifier-policies
                         (cons (mcons key show?) identifier-policies))
                   (send look-ctl append "")
                   (update-list-view i key show?)]
                  [(key=? key (mcar (car policies)))
                   (set-mcdr! (car policies) show?)
                   (update-list-view i key show?)]
                  [else (loop (add1 i) (cdr policies))])))))

    (define/private (update-list-view index key show?)
      (send look-ctl set-data index key)
      (send look-ctl set-string
            index
            (string-append (if show? "show " "hide ")
                           (key->text key))))

    (define/private (delete-selected)
      (define to-delete (sort (send look-ctl get-selections) <))
      (set! identifier-policies
            (let loop ([i 0] [policies identifier-policies] [to-delete to-delete])
              (cond [(null? to-delete) policies]
                    [(= i (car to-delete))
                     (loop (add1 i) (cdr policies) (cdr to-delete))]
                    [else
                     (cons (car policies)
                           (loop (add1 i) (cdr policies) to-delete))])))
      (for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))

    (super-new)
    (update-visibility)))

(define (get-id-key id)
  id
  #; ;; FIXME
  (let ([binding (identifier-binding id)])
    (get-id-key/binding id binding)))

(define (get-id-key/binding id binding)
  (cond [(pair? binding)
         (list (car binding) (cadr binding))]
        [else id]))

(define (key=? key1 key2)
  (cond [(and (identifier? key1) (identifier? key2))
         (free-identifier=? key1 key2)]
        [(and (pair? key1) (pair? key2))
         (and (equal? (car key1) (car key2))
              (equal? (cadr key1) (cadr key2)))]
        [else #f]))

(define (key->text key)
  (cond [(pair? key)
         (let ([name (cadddr key)]
               [mod (caddr key)])
           (format "'~s' from ~a"
                   name
                   (mpi->string mod)))]
        [else (symbol->string (syntax-e key))]))