(module size-snip mzscheme
  (require (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "pretty.ss")
           (lib "framework.ss" "framework"))
  
  (provide reflowing-snip<%>
           size-editor-snip%
           default-pretty-printer
           resizing-pasteboard-mixin)
  
  (define (default-pretty-printer v port w spec)
    (parameterize ([pretty-print-columns w])
      (pretty-print v port)))
  
  (define reflowing-snip<%>
    (interface ()
      reflow-program))
  
  (define (resizing-pasteboard-mixin pb%)
    (class pb%
      
      (define/augment (on-interactive-resize snip)
        (when (is-a? snip reflowing-snip<%>)
          (send snip reflow-program))
        #;(super on-interactive-resize snip))
      
      (define/augment (after-interactive-resize snip)
        (when (is-a? snip reflowing-snip<%>)
          (send snip reflow-program))
        #;(super after-interactive-resize snip))
      
      (define/override (interactive-adjust-resize snip w h)
        (super interactive-adjust-resize snip w h)
        (when (is-a? snip reflowing-snip<%>)
          (send snip reflow-program)))
      (super-new)))
  
  (define size-editor-snip%
    (class* editor-snip% (reflowing-snip<%>)
      (init-field expr pp char-width)
      (inherit get-admin)
      (define/public (get-expr) expr)
      
      (inherit get-editor)
      (define/public (reflow-program)
        (let ([ed (get-editor)])
          (when ed
            (let ([ed-ad (send ed get-admin)])
              (when ed-ad
                (let ([dc (send ed get-dc)]
                      [wb (box 0)]
                      [std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
                  (send ed-ad get-view #f #f wb #f)
                  (let-values ([(tw _1 _2 _3) (send dc get-text-extent "w"
                                                    (and std-style
                                                         (send std-style get-font)))])
                    (let ([new-width (max 1 (inexact->exact (floor (/ (- (unbox wb) 2) tw))))])
                      (unless (equal? new-width char-width)
                        (set! char-width new-width)
                        (format-expr))))))))))
      
      
      (define/public (format-expr)
        (let* ([text (get-editor)]
               [port (make-output-port
                      'graph-port
                      always-evt
                      (lambda (bytes start end buffering? enable-breaks?)
                        (send text insert (bytes->string/utf-8 (subbytes bytes start end))
                              (send text last-position)
                              (send text last-position))
                        (- end start))
                      void)])
          (send text begin-edit-sequence)
          (send text thaw-colorer)
          (send text set-styles-sticky #f)
          (send text erase)
          (pp expr port char-width text)
          (when (char=? #\newline (send text get-character (- (send text last-position) 1)))
            (send text delete (- (send text last-position) 1) (send text last-position)))
          (send text freeze-colorer)
          (send text end-edit-sequence)))

      (super-new))))