(module mred-extensions mzscheme
  (require (lib "class.ss")
           (lib "mred.ss" "mred")
           (prefix f: (lib "framework.ss" "framework"))
           (lib "pretty.ss")
           "testing-shared.ss"
	   (lib "string-constant.ss" "string-constants")
           (lib "bitmap-label.ss" "mrlib"))

  (provide
   stepper-bitmap
   stepper-canvas%
   stepper-text%
   snip?
   stepper-warning%
   finished-text)
   
  (define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1)))
  (define reduct-highlight-color (make-object color% 255 255 255))
  (define redex-highlight-color (make-object color% 255 255 255))
  (send test-dc try-color (make-object color% 212 159 245) reduct-highlight-color)
  (send test-dc try-color (make-object color% 193 251 181) redex-highlight-color)
  
  (define error-delta (make-object style-delta% 'change-style 'italic))
  (send error-delta set-delta-foreground "RED")
  
  (define snip-delta (make-object style-delta% 'change-alignment 'top))
  


  ;;;; VERTICAL-SEPARATOR : the red arrow that separates the left half of the display from the right half.
  
  (define red-arrow-bitmap
    (make-object bitmap% (build-path (collection-path "icons") "red-arrow.bmp") 'bmp))

  (unless (send red-arrow-bitmap ok?)
    (error 'red-arrow-bitmap "unable to load red-arrow bitmap"))
  
  (define vertical-separator-snipclass
    (make-object
     (class snip-class% ()
       (override read)
       
       (define (read s)
         (let ([size-box (box 0)])
           (send s get size-box)
           (make-object vertical-separator-snip% 100)))
       
       (super-instantiate ()))))
  
  (send* vertical-separator-snipclass
    (set-version 1)
    (set-classname "drscheme:vertical-separator-snip%"))
  
  (send (get-the-snip-class-list) add vertical-separator-snipclass)
  
  (define vertical-separator-snip%
    (class snip% ()
      (inherit get-style set-snipclass set-flags get-flags get-admin)
      (public set-height!)
      (override write copy get-extent draw)
      
      (init-field height)
      

      (define bitmap-width 15.0)
      (define left-white 0.0)
      (define right-white 3.0)
      (define bitmap-height 10.0)
      
      (define (set-height! x) 
        (set! height (max x bitmap-height)))
      
      (define (write s) 
        (send s put (char->integer #\r)))        ; this can't be right...?
      
      (define (copy)
        (let ([s (make-object vertical-separator-snip% height)])
          (send s set-style (get-style))
          s))
      
      (define (get-extent dc x y w-box h-box descent-box space-box lspace-box rspace-box)
        (for-each (lambda (box) (unless (not box) (set-box! box 0)))
                  (list descent-box space-box lspace-box rspace-box))
        (unless (not w-box)
          (set-box! w-box (+ left-white right-white bitmap-width)))
        (unless (not h-box)
          (set-box! h-box height)))
      
      (define (draw dc x y left top right bottom dx dy draw-caret)
        (let ([y-offset (round (/ (- height bitmap-height) 2))]
              [x-offset left-white])
          (send dc draw-bitmap red-arrow-bitmap (+ x x-offset) (+ y y-offset))))
      
      (super-instantiate ())
      (set-snipclass vertical-separator-snipclass)))
  
  
  ;;;; end of vertical snip-stuff
  
  (define stepper-editor-snip%
    (class editor-snip% ()
      (inherit get-editor set-min-width set-max-width)
      (public*
        [set-new-width
         (lambda (width canvas)
           (set-min-width width)
           (set-max-width width)
           (let ([editor (get-editor)])
             (when editor
               (send editor reset-pretty-print-width width canvas))))])
      (super-instantiate (#f #f 0 0 0 0 0 0 0 0))))
                                                                                                              
                                                                  ;                                    ;;    ;
       ;                                                          ;              ;                 ;  ;  ;  ; 
  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;         ;;;  ;   ;  ; ;;;         ;;;;  ;;;  ;    ; ;;;;;  ; ;  
 ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;     ;   ;  ;;   ;         ;   ;   ;  ;  ;   ;   ;; ;   
 ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;     ;   ;  ;    ;         ;   ;   ;   ;;    ;     ;    
  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;   ;;   ;   ;  ;    ;  ;;;;;  ;   ;;;;;   ;;    ;     ; ;; 
    ;  ;   ;      ;    ;  ;    ;  ;      ;              ;  ;   ;  ;    ;         ;   ;       ;;    ;    ; ;  ;
    ;  ;   ;      ;;   ;  ;;   ;  ;      ;              ;  ;  ;;  ;;   ;         ;   ;      ;  ;   ;   ;  ;  ;
 ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;           ;;;    ;; ;  ; ;;;           ;;  ;;;; ;    ;   ;;;    ;; 
                  ;       ;                                                                                   
                  ;       ;                                                                                   
  
  ; the stepper-sub-text% class is used to hold an individual list of sexps, with one or more highlights.
  ; there are four of them (* NB: now only two! 2005-08) in the stepper window.
  
  (define stepper-sub-text%
    (class f:text:standard-style-list% ()
      
      (init-field exps highlight-color)

      (inherit insert get-style-list set-style-list change-style highlight-range last-position lock erase
               begin-edit-sequence end-edit-sequence get-start-position select-all clear)
      
      (public* [reset-pretty-print-width
                (lambda (inner-width canvas)
                  (begin-edit-sequence)
                  (let* ([style (send (get-style-list) find-named-style "Standard")]
                         [char-width (send style get-text-width (send canvas get-dc))]
                         [width (floor (/ (- inner-width 18) char-width))])
                    (reformat-sexp width)
                    (end-edit-sequence)))])
      
      (define highlight-table (make-hash-table 'weak))
      
      (define stripped-exps
        (map (lambda (exp) (strip-to-sexp exp highlight-table)) exps))
      
      (define pretty-printed-width #f)
      (define clear-highlight-thunks null)
      (define/private (reset-style)
        (change-style (send (get-style-list) find-named-style "Standard")))
      (define/private (set-last-style)
        (change-style (send (get-style-list) find-named-style "Standard")
		      (sub1 (last-position))
		      (last-position)))
               
      (define/private (reformat-sexp width)
        (when (not (eq? pretty-printed-width width))
          (set! pretty-printed-width width)
          (format-whole-step)))
               
      (define highlight-begin #f)
               
      (inherit get-dc)
      
      (define/private (format-sexp sexp)
        (define text-port (open-output-text-editor this))

        (parameterize 
            ([pretty-print-columns pretty-printed-width]
             
             ; the pretty-print-size-hook decides whether this object should be printed by the new pretty-print-hook
             [pretty-print-size-hook
              (lambda (value display? port)
                (let ([looked-up (hash-table-get highlight-table value (lambda () #f))])
                  (cond
                    [(is-a? value snip%) 
                     ;; Calculate the effective width of the snip, so that
                     ;;  too-long lines (as a result of large snips) are broken
                     ;;  correctly. When the snip is actusally inserted, its width
                     ;;  will be determined by `(send snip get-count)', but the number
                     ;;  returned here triggers line breaking in the pretty printer.
                     (let ([dc (get-dc)]
                           [wbox (box 0)])
                       (send value get-extent dc 0 0 wbox #f #f #f #f #f)
                       (let-values ([(xw dc dc2 dc3) (send dc get-text-extent "x")])
                         (max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))]
                    [(and looked-up (not (eq? looked-up 'non-confusable)))
                     (string-length (format "~s" (car looked-up)))]
                    [else #f])))]
             
             [pretty-print-print-hook
              ; this print-hook is called for confusable highlights and for images.
              (lambda (value display? port)
                (let ([to-display (cond 
                                    [(hash-table-get highlight-table value (lambda () #f)) => car]
                                    [else value])])
                  (cond 
                    [(is-a? to-display snip%) 
                     (write-special (send to-display copy) port) (set-last-style)]
                    [else 
                     (write-string (format "~s" to-display) port)])))]
             [pretty-print-print-line
              (lambda (number port old-length dest-columns)
                (when (and number (not (eq? number 0)))
                  (newline port))
                0)]
             [pretty-print-pre-print-hook
              (lambda (value p)
                (when (hash-table-get highlight-table value (lambda () #f))
                  (set! highlight-begin (get-start-position))))]
             [pretty-print-post-print-hook
              (lambda (value p)
                (when (hash-table-get highlight-table value (lambda () #f))
                  (let ([highlight-end (get-start-position)])
                    (unless highlight-begin
                      (error 'format-whole-step "no highlight-begin to match highlight-end"))
                    (set! clear-highlight-thunks
                          (cons (highlight-range highlight-begin highlight-end highlight-color #f #f)
                                clear-highlight-thunks))
                    (set! highlight-begin #f))))]
             ;; mflatt: MAJOR HACK - this setting needs to come from the language
             ;;  somehow
             [read-case-sensitive #t])
          (pretty-print sexp text-port)))
             
      (define/public (format-whole-step)
        (lock #f)
        (begin-edit-sequence)
        (for-each (lambda (fun) (fun)) clear-highlight-thunks)
        (set! clear-highlight-thunks null)
        (select-all)
        (clear)
        (reset-style)
        (let loop ([remaining stripped-exps] [first #t])
          (unless (null? remaining)
            (unless first (insert #\newline))
            (format-sexp (car remaining))
            (loop (cdr remaining) #f)))
        (end-edit-sequence)
        (lock #t))
      
      (super-instantiate ())))
  
                                                   
                                                                  ;                                                                        ;;    ;
       ;                                                          ;                                                  ;                 ;  ;  ;  ; 
  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;         ;;;  ;   ;  ; ;;;           ;;;   ; ;; ; ;;  ;;;   ; ;;       ;;;;  ;;;  ;    ; ;;;;;  ; ;  
 ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;     ;   ;  ;;   ;         ;   ;  ;;   ;;   ;   ;  ;;          ;   ;   ;  ;  ;   ;   ;; ;   
 ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;     ;   ;  ;    ;         ;   ;  ;    ;    ;   ;  ;           ;   ;   ;   ;;    ;     ;    
  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;   ;;   ;   ;  ;    ;  ;;;;;  ;;;;;  ;    ;    ;   ;  ;    ;;;;;  ;   ;;;;;   ;;    ;     ; ;; 
    ;  ;   ;      ;    ;  ;    ;  ;      ;              ;  ;   ;  ;    ;         ;      ;    ;    ;   ;  ;           ;   ;       ;;    ;    ; ;  ;
    ;  ;   ;      ;;   ;  ;;   ;  ;      ;              ;  ;  ;;  ;;   ;         ;      ;    ;    ;   ;  ;           ;   ;      ;  ;   ;   ;  ;  ;
 ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;           ;;;    ;; ;  ; ;;;           ;;;;  ;    ;     ;;;   ;            ;;  ;;;; ;    ;   ;;;    ;; 
                  ;       ;                                                                                                                       
                  ;       ;                                                                                                                       
  
  ; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four^H^H^H^Htwo stepper "text" spots.
  ; it is used for error messages.
  
  (define stepper-sub-error-text%
    (class f:text:standard-style-list% ()
  
      (init-field error-msg)
      
      (inherit get-style-list last-position set-style-list insert change-style auto-wrap
               set-max-width)
      
      (public* [reset-pretty-print-width 
                (lambda (inner-width canvas)
                  (set-max-width inner-width))])
      
      (super-instantiate ())
      (let ([before-error-msg (last-position)])
        (change-style (send (get-style-list) find-named-style "Standard"))
        (auto-wrap #t)
        (insert error-msg)
        (change-style error-delta before-error-msg (last-position)))))
                                                                                                   
                                                                                            ;;    ;
       ;                                                                                   ;  ;  ; 
  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;         ;;;   ;;;   ; ;;  ;   ;   ;;;    ;;; ;  ; ;  
 ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;     ;   ;  ;;  ; ;   ;  ;   ;  ;     ;; ;   
 ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;         ;  ;   ;  ; ;       ;  ;       ;    
  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;  ;      ;;;;  ;   ;  ; ;    ;;;;   ;;     ; ;; 
    ;  ;   ;      ;    ;  ;    ;  ;      ;           ;     ;   ;  ;   ;  ; ;   ;   ;     ;   ; ;  ;
    ;  ;   ;      ;;   ;  ;;   ;  ;      ;           ;     ;   ;  ;   ;  ;;    ;   ;     ;  ;  ;  ;
 ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;            ;;;   ;;;;; ;   ;   ;     ;;;;; ;;;  ;    ;; 
                  ;       ;                                                                        
                  ;       ;                                                                        
  
  ;; the stepper-canvas% overrides the editor-canvas simply so that on-size messages get passed to
  ;; the enclosed editor.
  
  (define stepper-canvas%
    (class editor-canvas% ()
      (inherit get-editor)
      (override*
        [on-size
         (lambda (width height)
           (super on-size width height)
           (let ([editor (get-editor)])
             (when editor
               (send editor reset-width this))))])
 
      (super-instantiate ())))
                                                                                  
                                                                           ;;    ;
       ;                                             ;                 ;  ;  ;  ; 
  ;;; ;;;;  ;;;   ; ;;;   ; ;;;    ;;;   ; ;;       ;;;;  ;;;  ;    ; ;;;;;  ; ;  
 ;     ;   ;   ;  ;;   ;  ;;   ;  ;   ;  ;;          ;   ;   ;  ;  ;   ;   ;; ;   
 ;     ;   ;   ;  ;    ;  ;    ;  ;   ;  ;           ;   ;   ;   ;;    ;     ;    
  ;;   ;   ;;;;;  ;    ;  ;    ;  ;;;;;  ;    ;;;;;  ;   ;;;;;   ;;    ;     ; ;; 
    ;  ;   ;      ;    ;  ;    ;  ;      ;           ;   ;       ;;    ;    ; ;  ;
    ;  ;   ;      ;;   ;  ;;   ;  ;      ;           ;   ;      ;  ;   ;   ;  ;  ;
 ;;;    ;;  ;;;;  ; ;;;   ; ;;;    ;;;;  ;            ;;  ;;;; ;    ;   ;;;    ;; 
                  ;       ;                                                       
                  ;       ;                                                       
    
  ; the stepper-text% is the principal inhabitant of the stepper window. It keeps
  ; track of all of the sexps & error messages in a given step, reformatting as necessary.
  
   ;; constructor : ((union (listof sexp) string) (union (listof sexp) string) -> )
  
  (define stepper-text%
    (class f:text:standard-style-list% ()
      
      (init-field left-side right-side)

      (inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap
               begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list
               get-admin get-snip-location get-dc needs-update hide-caret)
      (public* [reset-width 
                (lambda (canvas)
                  (lock #f)
                  (begin-edit-sequence)
                  (let* ([width-box (box 0)]
                         [canvas-width (begin (send (get-admin) get-view #f #f width-box #f) (unbox width-box))]
                         [dc (send canvas get-dc)])
                    (unless (and old-width (= canvas-width old-width))
                      (let* ([minus-cursor-margin (- canvas-width 2)]
                             [vert-separator-width-box (box 0)]
                             [_ (send vert-separator get-extent dc 0 0 vert-separator-width-box
                                      #f #f #f #f #f)]
                             [vert-separator-width (unbox vert-separator-width-box)]
                             [minus-center-bar (- minus-cursor-margin vert-separator-width)]
                             [l-r-box-widths (floor (/ minus-center-bar 2))])
                        (send before-snip set-new-width l-r-box-widths canvas)
                        (send after-snip set-new-width l-r-box-widths canvas)
                        (coordinate-snip-sizes))
                      (set! old-width canvas-width))
                    (end-edit-sequence)
                    (lock #t)))])

      (define old-width #f)
      (define before-snip (make-object stepper-editor-snip%))
      (define vert-separator (make-object vertical-separator-snip% 10))
      (define after-snip (make-object stepper-editor-snip%))
      
      ;; coordinate-snip-sizes : make the vertical separator snip the right size, then notify the administrator.
      (define/private (coordinate-snip-sizes)
        (let* ([get-snip-height
                (lambda (snip)
                  (let* ([top-box (box 0)]
                         [bottom-box (box 0)])
                    (get-snip-location snip #f top-box #f)
                    (get-snip-location snip #f bottom-box #t)
                    (- (unbox bottom-box) (unbox top-box))))]
               [max-height (max (get-snip-height before-snip) (get-snip-height after-snip))])
          (send vert-separator set-height! (- max-height 4))
          (let ([w-box (box 0)]
                [h-box (box 0)])
            (send vert-separator get-extent #f 0 0 w-box h-box #f #f #f #f)
            (send (send vert-separator get-admin) resized vert-separator #t))))
      
      

      (super-instantiate ())
      (hide-caret #t)
      
      ;; insert the editor-snips & separator-snip, and change the style.
      (let ([before-position (last-position)])
        (for-each (lambda (x) (insert x)) ;; NB: eta-expansion necessary because insert is a method, not a procedure.
                  (list before-snip vert-separator after-snip))
        (change-style snip-delta before-position (last-position)))

      ;; attach the editors to the snips, and populate those editors.
      
      (define (setup-editor-snip snip error-or-exps highlight-color)
        (send snip set-editor 
              (cond [(string? error-or-exps) 
                     (make-object stepper-sub-error-text% error-or-exps)]
                    [else 
                     (make-object stepper-sub-text% error-or-exps highlight-color)])))
      
      (setup-editor-snip before-snip left-side redex-highlight-color)
      (setup-editor-snip after-snip right-side reduct-highlight-color)
      


      
      (lock #t)))
  
  (define finished-text
    (instantiate (class text% ()
                   (define/public (reset-width arg)
                     (void))
                   
                   (super-instantiate ())
                   
                   (inherit insert lock)
                   (insert "All of the definitions have been successfully evaluated.")
                   (lock #t)) 
      ()))
  
  (define (snip? val)
    (is-a? val snip%))
  
  (define warning-color "yellow")
  (define warning-font (send the-font-list find-or-create-font 18 'decorative 'normal 'bold #f))
  
  (define stepper-warning%
    (class canvas%
      
      (init-field warning-str)
       
      (inherit get-dc get-client-size)
      (define/override (on-paint)
        (let ([dc (get-dc)])
          (send dc set-font warning-font) 
          (let-values ([(cw ch) (get-client-size)]
                       [(tw th dont-care dont-care2) (send dc get-text-extent warning-str)])
            (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
            (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
            (send dc draw-rectangle 0 0 cw ch)
            (send dc draw-text 
                  warning-str
                  (- (/ cw 2) (/ tw 2))
                  (- (/ ch 2) (/ th 2))))))
      
      (super-instantiate ())
      (inherit min-width min-height stretchable-height)
      (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning-str warning-font)])
        (min-width (+ 2 (inexact->exact (ceiling tw))))
        (min-height (+ 2 (inexact->exact (ceiling th)))))
      
      (stretchable-height #f)))

  
  ;                                                                                          
  ;                                                                                          
  ;                                                                                          
  ;                    ;                                                                     
  ;                                                                                          
  ;          ;                             ;                                                 
  ;    ;;;  ;;;;  ; ;  ;   ; ;;           ;;;;   ;;;             ;;;    ;;;  ;     ;  ; ;;   
  ;   ;      ;    ;;   ;   ;;  ;           ;    ;   ;           ;      ;   ;  ;   ;   ;;  ;  
  ;   ;;     ;    ;    ;   ;    ;          ;   ;     ;          ;;    ;    ;   ; ;    ;    ; 
  ;    ;;    ;    ;    ;   ;    ;  ;;;;;;  ;   ;     ;  ;;;;;;   ;;   ;;;;;;    ;     ;    ; 
  ;      ;   ;    ;    ;   ;    ;          ;   ;     ;             ;  ;        ; ;    ;    ; 
  ;      ;   ;    ;    ;   ;;  ;           ;    ;   ;              ;   ;      ;   ;   ;;  ;  
  ;   ;;;     ;;  ;    ;   ; ;;             ;;   ;;;            ;;;     ;;;; ;     ;  ; ;;   
  ;                        ;                                                          ;      
  ;                        ;                                                          ;      
  ;                        ;                                                          ;      
  
  
  ; strip-to-sexp transforms a syntax-object to an s-expression.  The reason we can't
  ; just use syntax-object->datum for this is that certain syntax-objects must be
  ; represented by a gensym'ed pointer into a table.
                           
  (define (strip-to-sexp stx highlight-table)
    (define (strip-regular stx)
      (let* ([it (if (and (syntax? stx)
                          (eq? (syntax-property stx 'stepper-hint) 'from-xml))
                     (strip-xml stx)
                     stx)]
             [it
              (cond [(pair? it)
                     (cons (strip-regular (car it))
                           (strip-regular (cdr it)))]
                    [(syntax? it)
                     (strip-regular (syntax-e it))]
                    [else it])]
             [it
              (if (and (syntax? stx)
                       (syntax-property stx 'stepper-highlight))
                  (if (pair? it) 
                      (begin
                        (hash-table-put! highlight-table it 'non-confusable)
                        it)
                      (let ([new-sym (gensym "-placeholder")])
                        (hash-table-put! highlight-table new-sym (list it))
                        new-sym))
                  it)])
        it))
    
    ; strip-xml attempts to undo the expansion of quasiquote.  
    (define (strip-xml stx)
      ; we'll work on this later.
      "<xml box here>"
      ;(instantiate xml-snip% () [eliminate-whitespace-in-tags? #t])
      )
    
    (strip-regular stx))
  
  
  ;; stepper-bitmap : the image used for the stepper button
  (define stepper-bitmap
    (bitmap-label-maker
     (string-constant stepper-button-label)
     (build-path (collection-path "icons") "foot.png")))
                                                                     

  ;; testing code
  
  (define (stepper-text-test . args)
    (let* ([new-frame (make-object frame% "test-frame")]
           [new-text (apply make-object stepper-text% args)]
           [new-canvas (make-object stepper-canvas% new-frame new-text)])
      (send new-canvas min-width 200)
      (send new-canvas min-height 200)
      (send new-frame show #t)
      (send new-text reset-width new-canvas)
      new-canvas))
  
  
  #;(define a
    (stepper-text-test (build-stx-with-highlight `((* 13 (hilite (* 15 16)))))
                       (build-stx-with-highlight `((hilite (+ 3 4)) (define y 4) 13 14 (+  (hilite 13) (hilite #f)) 13 
                                                   298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f)))))
  
  ;; test out scroll bars
  #;(stepper-text-test (build-stx-with-highlight `(1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8))
                     (build-stx-with-highlight `(free!)))
  
  #;(stepper-text-test  `() "This is an error message" )
  
  #;(stepper-text-test  "This is another error message" `(poomp))
  )

