(module view mzscheme
  (require (lib "class.ss")
           (lib "list.ss")
           (lib "match.ss")
           (lib "mred.ss" "mred")
           (lib "framework.ss" "framework")
           (lib "hierlist.ss" "hierlist")

           (prefix drlink: "../drscheme-ui.ss")
           "interfaces.ss"
           "config.ss"
           "model2rml.ss"
           "rml.ss"
           "rml-styles.ss")

  (provide view%)
  
  ;; tree-view% <: hierarchical-list%
  (define tree-view%
    (class* hierarchical-list% ()
      (init-field view)
      
      (define/override (on-select item)
        (let [(model (send item user-data))]
          (ensure-tree-visible model)
          (send view show-model model #f)))
      (define (ensure-tree-visible model)
        (let* [(parent (send model get-parent))
               (parent-view-link (and parent (send parent get-view-link)))]
          (when (and parent (not (send parent-view-link is-open?)))
            (ensure-tree-visible parent)
            (send parent-view-link open))))
      (super-instantiate ())))
  
  ;; tree-view-item-mixin : mixin
  (define tree-view-item-mixin
    (mixin (hierarchical-list-item<%>) (hierarchical-list-item<%>) 
      (super-instantiate())))

  ;; tree-view-compound-item-mixin : mixin
  (define tree-view-compound-item-mixin
    (mixin (hierarchical-list-compound-item<%>) (hierarchical-list-compound-item<%>)
      (super-instantiate ())))
      
  ;; View Frame
  (define view%
    (class* object% (view<%>)
      (init ((-controller controller))
            ((-root-model root-model)))
      
      (public show
              show-model
              set-selection
              update-model-view
              get-controller
              get-selected-model)
      
      (super-instantiate ())

      ;; root-model : model<%>
      (define root-model -root-model)

      ;; controller : controller<%>
      (define controller -controller)

      (define frame #f)
      (define details #f)
      (define tree-view #f)
      (define model->rml (instantiate model->rml% () (controller controller)))
      (define style-map schemeunit-style-map)
      (define editor (instantiate rml:text% () (style-map style-map)))
      
      ;; create : -> void
      (define (create)
        (define -frame
          (instantiate frame% ()
            (label FRAME-LABEL) (height FRAME-INIT-HEIGHT)
            (width (+ TREE-INIT-WIDTH DETAILS-CANVAS-INIT-WIDTH))))
        (define -hpane 
          (instantiate panel:horizontal-dragable% () (parent -frame)))
        (define -lpane
          (instantiate vertical-pane% () (parent -hpane)))
        (define -rpane 
          (instantiate vertical-pane% () (parent -hpane)))
        (define -details-canvas
          (instantiate canvas:wide-snip% () (parent -rpane) (editor editor)))
        (define -tree-view (build-tree-view -lpane))
        (define -buttonpane
          (instantiate horizontal-pane% () (parent -lpane) (stretchable-height #f)))
        (instantiate button% () 
          (label "Run") (callback run-callback) (parent -buttonpane))
        (instantiate button% ()
          (label "Clear") (callback clear-callback) (parent -buttonpane))
        (send editor lock #t)
        (with-handlers ([exn:fail? void])
          (send -hpane set-percentages VIEW-PANE-PERCENTS))
        (set! frame -frame)
        (set! tree-view -tree-view))

      ;; METHODS
      
      ;; show : boolean -> void
      (define (show ?)
        (send frame show ?))
      
      ;; model-shown : model<%> | #f
      ;; The model currently displayed in the Details view, of #f is none.
      (define model-shown #f)
      
      ;; show-model : model<%> [boolean] -> void
      ;; Ensures that a particular model is displayed in the Details area.
      ;; If it already is, only redraw if redisplay is provided and true.
      (define show-model
        (case-lambda
          [(model) (show-model model #t)]
          [(model redisplay?)
           (when (or redisplay? (not (eq? model-shown model)))
             (set! model-shown model)
             (send* editor
               (lock #f)
               (display (send model->rml model->rml/long model))
               (lock #t)))]))

      ;; build-tree-view
      (define (build-tree-view area)
        (let ([tree (instantiate tree-view% () (parent area) (view this))])
          (populate-tree root-model tree)
          (let ([view-link (send root-model get-view-link)])
            (when (is-a? view-link hierarchical-list-compound-item<%>)
              (send view-link open))
            (send view-link select #t))
          tree))
      
      ;; populate-tree : model<%> (union tree-view% compound-item%) -> void
      (define (populate-tree model parent)
        (cond [(is-a? model model-suite<%>)
               (populate-tree/item model (send parent new-list))]
              [(is-a? model model-case<%>)
               (populate-tree/item model (send parent new-item))]))
 
      ;; populate-tree/item : model<%> (union compound-item% item%) -> void
      (define (populate-tree/item model item)
        (send model set-view-link item)
        (send item user-data model)
        (cond [(is-a? model model-suite<%>)
               (insert-text (send item get-editor)
                            (send model get-name)
                            (send style-map get-style 'bold))
               (when (is-a? model model-suite<%>)
                 (for-each (lambda (c) (populate-tree c item))
                           (send model get-children)))]
              [(is-a? model model-case<%>)
               (insert-text (send item get-editor)
                            (send model get-name)
                            (send style-map get-style 'normal))]))
      
      ;; set-selection
      ;; Set the selection to model and notify of change if necessary
      (define (set-selection model)
        (unless (eq? (get-selected-model) model)
          (send (send model get-view-link) select #t)
          (send controller on-view-selection-change this model)))
      
      ;; update-model-view : model<%> -> void
      ;; The given model has changed state--update the view to reflect it.
      (define (update-model-view model)
        (let* [(editor (send (send model get-view-link) get-editor))
               (style-name
                (cond [(not (send model executed?)) 'test-unexecuted]
                      [(send model success?) 'test-success]
                      [(send model failure?) 'test-failure]
                      [(send model error?) 'test-error]))
               (style (send style-map get-style style-name))]
          (send* editor
            (begin-edit-sequence #f)
            (select-all)
            (change-style style)
            (end-edit-sequence)))
        (let* [(displayed-model (get-selected-model))]
          (when (eq? displayed-model model)
            (show-model model))))

      (define (run-callback . _)
        (let ([selected-model (get-selected-model)])
        (when selected-model
          (send controller run-model selected-model))))

      (define (clear-callback . _)
        (send editor begin-edit-sequence #f)
        (let ([selected-model (get-selected-model)])
          (when selected-model
            (send controller clear-model selected-model)))
        (send editor end-edit-sequence))
      
      ;; get-controller : -> controller<%>
      (define (get-controller) controller)
      
      ;; get-selected-model : -> model<%>
      (define (get-selected-model)
        (let [(item (send tree-view get-selected))]
          (and item (send item user-data))))
      
      (create)
      ))
  
  )