#lang mzscheme
(require scheme/class
         mred
         framework/framework
         scheme/list
         scheme/match
         mzlib/kw
         syntax/boundmap
         "interfaces.ss"
         "params.ss"
         "controller.ss"
         "display.ss"
         "keymap.ss"
         "hrule-snip.ss"
         "properties.ss"
         "text.ss"
         "util.ss")
(provide widget%)

;; widget%
;; A syntax widget creates its own syntax-controller.
(define widget%
  (class* object% (widget-hooks<%>)
    (init parent)
    (init-field config)

    (field [controller (new controller%)])

    (define -main-panel
      (new vertical-panel% (parent parent)))
    (define -split-panel
      (new panel:horizontal-dragable% (parent -main-panel)))
    (define -text (new browser-text%))
    (define -ecanvas
      (new editor-canvas% (parent -split-panel) (editor -text)))
    (define -props-panel (new horizontal-panel% (parent -split-panel)))
    (define props
      (new properties-view%
           (parent -props-panel)
           (controller controller)))

    (define/public (setup-keymap)
      (new syntax-keymap% 
           (editor -text)
           (config config)))

    (send -text set-styles-sticky #f)
    (send -text lock #t)

    ;; syntax-properties-controller<%> methods

    (define/public (props-shown?)
      (send -props-panel is-shown?))

    (define/public (toggle-props)
      (show-props (not (send -props-panel is-shown?))))

    (define/public (show-props show?)
      (if show?
          (unless (send -props-panel is-shown?)
            (let ([p (send config get-props-percentage)])
              (send -split-panel add-child -props-panel)
              (update-props-percentage p))
            (send -props-panel show #t))
          (when (send -props-panel is-shown?)
            (send -split-panel delete-child -props-panel)
            (send -props-panel show #f))))

    (send config listen-props-percentage
          (lambda (p)
            (update-props-percentage p)))
    (send config listen-props-shown?
          (lambda (show?)
            (show-props show?)))

    (define/private (update-props-percentage p)
      (send -split-panel set-percentages
            (list (- 1 p) p)))

    ;;

    (define/public (get-controller) controller)

    ;;

    (define/public (get-main-panel) -main-panel)

    (define/public (shutdown)
      (when (props-shown?)
        (send config set-props-percentage
              (cadr (send -split-panel get-percentages)))))

    ;; syntax-browser<%> Methods

    (define/public (add-text text)
      (with-unlock -text
        (send -text insert text)))

    (define/public (add-error-text text)
      (with-unlock -text
        (let ([a (send -text last-position)])
          (send -text insert text)
          (let ([b (send -text last-position)])
            (send -text change-style error-text-style a b)))))

    (define/public (add-clickback text handler)
      (with-unlock -text
        (let ([a (send -text last-position)])
          (send -text insert text)
          (let ([b (send -text last-position)])
            (send -text set-clickback a b handler)
            (send -text change-style clickback-style a b)))))

    (define/public add-syntax
      (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
                      hi2-color [hi2-stxs null])
        (define (get-binder id)
          (module-identifier-mapping-get alpha-table id (lambda () #f)))
        (when (and (pair? hi-stxs) (not hi-color))
          (error 'syntax-widget%::add-syntax "no highlight color specified"))
        (let ([display (internal-add-syntax stx)]
              [definite-table (make-hash-table)])
          (when (and hi2-color (pair? hi2-stxs))
            (send display highlight-syntaxes hi2-stxs hi2-color))
          (when (and hi-color (pair? hi-stxs))
            (send display highlight-syntaxes hi-stxs hi-color))
          (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
          (when alpha-table
            (let ([range (send display get-range)]
                  [start (send display get-start-position)])
              (define (adjust n) (+ start n))
              (for-each
               (lambda (id)
                 #; ;; DISABLED
                 (match (identifier-binding id)
                   [(list src-mod src-name nom-mod nom-name _)
                    (for-each (lambda (id-r)
                                (send -text add-billboard
                                      (adjust (car id-r))
                                      (adjust (cdr id-r))
                                      (string-append "from "
                                                     (mpi->string src-mod))
                                      (if (hash-table-get definite-table id #f)
                                          "blue"
                                          "purple")))
                              (send range get-ranges id))]
                   [_ (void)])

                 (let ([binder (get-binder id)])
                   (when binder
                     (for-each
                      (lambda (binder-r)
                        (for-each (lambda (id-r)
                                    (if (hash-table-get definite-table id #f)
                                        (send -text add-arrow
                                              (adjust (car binder-r))
                                              (adjust (cdr binder-r))
                                              (adjust (car id-r))
                                              (adjust (cdr id-r))
                                              "blue")
                                        (send -text add-question-arrow
                                              (adjust (car binder-r))
                                              (adjust (cdr binder-r))
                                              (adjust (car id-r))
                                              (adjust (cdr id-r))
                                              "purple")))
                                  (send range get-ranges id)))
                      (send range get-ranges binder)))))
               (send range get-identifier-list))))
          display)))

    (define/public (add-separator)
      (with-unlock -text
        (send* -text
          (insert (new hrule-snip%))
          (insert "\n"))))

    (define/public (erase-all)
      (with-unlock -text
        (send -text erase)
        (send -text delete-all-drawings))
      (send controller remove-all-syntax-displays))

    (define/public (get-text) -text)

    ;; internal-add-syntax : syntax -> display
    (define/private (internal-add-syntax stx)
      (with-unlock -text
        (parameterize ((current-default-columns (calculate-columns)))
          (let ([display (print-syntax-to-editor stx -text controller)])
            (send* -text
              (insert "\n")
              ;(scroll-to-position current-position)
              )
            display))))

    (define/private (calculate-columns)
      (define style (code-style -text))
      (define char-width (send style get-text-width (send -ecanvas get-dc)))
      (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
      (sub1 (inexact->exact (floor (/ canvas-w char-width)))))

    ;; Initialize
    (super-new)
    (setup-keymap)))

(define clickback-style
  (let ([sd (new style-delta%)])
    (send sd set-delta 'change-toggle-underline)
    (send sd set-delta-foreground "blue")
    sd))

(define error-text-style
  (let ([sd (new style-delta%)])
    (send sd set-delta 'change-italic)
    (send sd set-delta-foreground "red")
    sd))

;; Specialized classes for widget

(define browser-text%
  (class (text:arrows-mixin
          (text:tacking-mixin
           (text:mouse-drawings-mixin
            (text:hover-mixin
             (text:hide-caret/selection-mixin
              (editor:standard-style-list-mixin text:basic%))))))
    (inherit set-autowrap-bitmap)
    (define/override (default-style-name) "Basic")
    (super-new (auto-wrap #t))
    (set-autowrap-bitmap #f)))