(module widget mzscheme
  (require "interfaces.ss"
           "pretty-snip.ss"
           "color.ss"
           "hrule-snip.ss"
           "partition.ss"
           "properties.ss"
           "prefs.ss"
           (lib "class.ss")
           (lib "framework.ss" "framework")
           (lib "mred.ss" "mred"))
  (provide syntax-controller%
           syntax-widget%
           syntax-browser-frame%
           syntax-snip%)
  
  ;; syntax-controller%
  (define syntax-controller%
    (class* object% (syntax-controller<%>
                     syntax-browser<%>
                     syntax-pp-snip-controller<%>
                     color-controller<%>)
      (init-field (administrative-syntax? (lambda (x) #f)))
      
      ;; syntax-browser<%> Methods
      
      (define/public (add-text text)
        (define (action view)
          (send* (send view get-display-text)
            (lock #f)
            (insert text)
            (lock #t)))
        (set! stored-actions (cons action stored-actions))
        (for-each action views))
      
      (define/public add-syntax
        (case-lambda
          [(stx) 
           (internal-add-syntax stx null #f)]
          [(stx hi-stxs hi-color)
           (internal-add-syntax stx hi-stxs hi-color)]))
      
      (define/public (add-separator)
        (define (action view)
          (send* (send view get-display-text)
            (lock #f)
            (insert (new hrule-snip%))
            (insert "\n")
            (lock #t)))
        (set! stored-actions (cons action stored-actions))
        (for-each action views))
      
      (define/public (select-syntax stx)
        (set! selected-syntax stx)
        (for-each (lambda (v) (send v props:show-syntax stx)) views)
        (for-each (lambda (colorer) (send colorer show-syntax stx))
                  (map cdr a:snip=>colorer)))
      
      (define/public (highlight-syntax snip stx)
        (cond [(assq snip a:snip=>colorer)
               => (lambda (p) (send (cdr p) highlight-syntaxes (list stx)))]
              [(not snip)
               (void)]))
      
      ;; syntax-pp-snip-controller<%> Methods
      
      (define/public (on-select-syntax snip stx)
        (set! selected-snip snip)
        (select-syntax stx))
      
      ;; --
      ;; views : (listof syntax-view<%>)
      (define views null)
      
      ;; stored-actions : (listof (-> void))
      (define stored-actions null)
      
      (define selected-syntax #f)
      (define selected-snip #f)
      (define a:snip=>colorer null)
      
      (define/private (internal-add-syntax stx hi-stxs hi-color)
        (define (action view)
          (internal-add-syntax/view stx hi-stxs hi-color view))
        (set! stored-actions (cons action stored-actions))
        (for-each action views))
      
      (define/private (internal-add-syntax/view stx hi-stxs hi-color view)
        (let* ([new-snip (new snip-typesetter% (controller this))]
               [new-syntax-pp (new syntax-pp% (main-stx stx) (typesetter new-snip))]
               [new-colorer (new syntax-snip-colorer% 
                                 (syntax-pp new-syntax-pp)
                                 (snip new-snip)
                                 (controller this))]
               [-text (send view get-display-text)])
          (set! a:snip=>colorer 
                (cons (cons new-snip new-colorer) a:snip=>colorer))
          (let ([current-position (send -text last-position)])
            (send* -text
              (lock #f)
              (insert new-snip)
              (insert "\n")
              (lock #t)
              (scroll-to-position current-position)))
          (send new-colorer highlight-syntaxes hi-stxs hi-color)))
      
      ;; color-controller<%> Methods
      
      (define/public (get-primary-partition)
        -primary-partition)
      
      (define/public (get-secondary-partition)
        -secondary-partition)
      
      (define/public (get-administrative-predicate)
        administrative-syntax?)
      
      (define -primary-partition (new-bound-partition))
      (define -secondary-partition #f)

      ;; syntax-controller<%> Methods
      ;; - select-syntax is above

      (define/public (add-view view)
        (set! views (cons view views))
        (for-each (lambda (action) (action view))
                  (reverse stored-actions))
        (select-syntax selected-syntax))
      
      (define/public (get-views) views)
      
      (define/public (on-update-identifier=? id=?)
        (set! -secondary-partition 
              (and id=? (new partition% (relation id=?))))
        (for-each (lambda (colorer) (send colorer refresh))
                  (map cdr a:snip=>colorer)))
      
      ;; Initialization
      (super-new)
      ))  
  
  ;; syntax-browser-frame%
  (define syntax-browser-frame%
    (class* frame% (syntax-view<%>)
      (init-field controller)
      
      ;; syntax-view<%> Methods

      (define/public (get-display-text) (send widget get-display-text))
      (define/public (props:show-syntax x) (send widget props:show-syntax x))
      
      ;; --
      (super-new (label "Syntax Browser")
                 (width (pref:width))
                 (height (pref:height)))
      (define widget (new syntax-widget% (parent this) (controller controller)))
      (define/public (get-widget) widget)
      (define/augment (on-close)
        (pref:width (send this get-width))
        (pref:height (send this get-height))
        (send widget on-close)
        (preferences:save)
        (inner (void) on-close))
      ))
  
  ;; syntax-widget%
  (define syntax-widget%
    (class* object% (syntax-view<%>)
      (init parent)
      (init-field controller)

      ;; syntax-view<%> Methods

      (define/public (get-display-text) -text)
      (define/public (props:show-syntax x)
        (send props show-syntax x))
      
      ;; --
      
      (define -parent parent)
      #;(define -controller #f)
      (define -panel (new vertical-panel% (parent -parent)))
      (define -control-panel 
        (new horizontal-pane% (parent -panel) (stretchable-height #f)))
      (define -choice (new choice% (label "identifer=?") (parent -control-panel)
                           (choices (map car identifier=-choices))
                           (callback (lambda _ (on-update-identifier=?-choice)))))
      (new button% 
           (label "Clear")
           (parent -control-panel)
           (callback (lambda _ (send controller select-syntax #f))))
      (new button%
           (label "Properties")
           (parent -control-panel)
           (callback (lambda _ (toggle-props))))
      
      (define -main-panel (new panel:horizontal-dragable% (parent -panel)))
      (define -text (new text%))
      (define -ecanvas (new editor-canvas% (parent -main-panel) (editor -text)))
      (define -props-panel (new horizontal-panel% (parent -main-panel)))
      (define props (new properties-view% (parent -props-panel)))
      (define -saved-panel-percentages #f)
      (send -main-panel set-percentages 
            (let ([pp (pref:props-percentage)]) (list (- 1 pp) pp)))
      (toggle-props)
      
      (define/private (toggle-props)
        (if (send -props-panel is-shown?)
            (begin (set! -saved-panel-percentages (send -main-panel get-percentages))
                   (send -main-panel delete-child -props-panel)
                   (send -props-panel show #f))
            (begin (send -main-panel add-child -props-panel)
                   (send -main-panel set-percentages -saved-panel-percentages)
                   (send -props-panel show #t))))
      
      (define/private (on-update-identifier=?-choice)
        (let ([id=? (get-identifier=?)])
          (send controller on-update-identifier=? id=?)))
      
      (define/private (get-identifier=?)
        (cond [(assoc (send -choice get-string-selection) 
                      identifier=-choices)
               => cdr]
              [else #f]))
      
      (define/public (on-close)
        (unless (= (cadr -saved-panel-percentages) (pref:props-percentage))
          (pref:props-percentage (cadr -saved-panel-percentages))))

      (send controller add-view this)
      (super-new)))
  
  
  ;; syntax-snip%
  (define syntax-snip%
    (class* editor-snip% (syntax-view<%>)
      (init-field controller)
      
      ;; snip% Methods
      
      (define/override (copy)
        (new syntax-snip% (controller controller)))
      
      ;; syntax-view<%> Methods
      
      (define/public (get-display-text) -text)
      (define/public (props:show-syntax x)
        (send props show-syntax x))
      
      ;; --
      
      (define -outer (new text%))
      (define -text (new text%))
      (define -text-snip (new editor-snip% (editor -text)))
      (super-new (editor -outer))
      
      (define -props-frame
        (new frame% (label "Properties and Configuration") (height (pref:height))
             (width (floor (* (pref:props-percentage) (pref:width))))))
      (define -choice (new choice% (label "identifer=?") (parent -props-frame)
                           (choices (map car identifier=-choices))
                           (callback (lambda _ (on-update-identifier=?-choice)))))
      (new message% (label " ") (parent -props-frame))
      (define props (new properties-view% (parent -props-frame)))
      (define style:normal (make-object style-delta% 'change-normal))
      (define style:hyper
        (let ([s (make-object style-delta% 'change-normal)])
          (send s set-delta 'change-toggle-underline)
          (send s set-delta-foreground "blue")
          s))
      (define style:bold
        (let ([s (make-object style-delta% 'change-normal)])
          (send s set-delta 'change-bold)
          s))
      
      (send -outer begin-edit-sequence)
      (outer:insert "Syntax browser" style:bold)
      (outer:insert "  ")
      (outer:insert "Clear" style:hyper
                    (lambda (x y z) (send controller select-syntax #f)))
      (outer:insert "  ")
      (outer:insert "Properties" style:hyper
                    (lambda (x y z) (show-properties)))
      (outer:insert "\n")
      (outer:insert -text-snip)
      (send -outer lock #t)
      (send -outer end-edit-sequence)
      
      (define/private outer:insert
        (case-lambda
          [(obj)
           (outer:insert obj style:normal)]
          [(text style)
           (outer:insert text style #f)]
          [(text style clickback)
           (let ([start (send -outer last-position)])
             (send -outer insert text)
             (let ([end (send -outer last-position)])
               (send -outer change-style style start end #f)
               (when clickback
                 (send -outer set-clickback start end clickback))))]))
      
      (define/private (show-properties)
        (unless (send -props-frame is-shown?)
          (send -props-frame show #t)))
      
      (define/private (on-update-identifier=?-choice)
        (let ([id=? (get-identifier=?)])
          (send controller on-update-identifier=? id=?)))
      
      (define/private (get-identifier=?)
        (cond [(assoc (send -choice get-string-selection) 
                      identifier=-choices)
               => cdr]
              [else #f]))
      
      ;; Initialization
      
      (send -outer hide-caret #t)
      (send -text hide-caret #t)
      (send -text lock #t)
      (send controller add-view this)))
  
  )