#lang scheme/base
(require scheme/gui/base
         scheme/class
         framework
         scheme/pretty
         "matcher.ss")

(provide reflowing-snip<%>
         size-editor-snip%
         size-text%
         default-pretty-printer
         initial-char-width
         resizing-pasteboard-mixin
         get-user-char-width)

(define initial-char-width (make-parameter 30))

;; get-user-char-width : value-bound-to-'initial-char-width'-parameter sexp -> number
(define (get-user-char-width cw/proc expr)
  (cond
    [(number? cw/proc) cw/proc]
    [else (cw/proc expr)]))

(define (default-pretty-printer v port w spec)
  (parameterize ([pretty-print-columns w]
                 [pretty-print-size-hook
                  (λ (val display? op)
                    (cond
                      [(hole? val) 4]
                      [(eq? val 'hole) 6]
                      [else #f]))]
                 [pretty-print-print-hook
                  (λ (val display? op)
                    (cond
                      [(hole? val)
                       (display "hole" op)]
                      [(eq? val 'hole) 
                       (display ",'hole" op)]))])
    (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))
      (inner (void) on-interactive-resize snip))
    
    (define/augment (after-interactive-resize snip)
      (when (is-a? snip reflowing-snip<%>)
        (send snip reflow-program))
      (inner (void) 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)))
    
    (inherit get-snip-location
             begin-edit-sequence
             end-edit-sequence
             find-first-snip
             get-dc)
    
    (super-new)))

(define size-editor-snip%
  (class* editor-snip% (reflowing-snip<%>)
    (init-field expr)
    (init pp)
    (init-field char-width)
    (define real-pp
      (if (procedure-arity-includes? pp 4)
          pp
          (lambda (v port w spec) (display (pp v) port))))
    
    (inherit get-admin)
    (define/public (get-expr) expr)
    (define/public (get-char-width) char-width)
    
    (define/override (resize w h)
      (super resize w h)
      (reflow-program))
    
    (inherit get-editor)
    ;; final
    (define/pubment (reflow-program)
      (let* ([tw (get-width-of-char)]
             [sw (get-snip-width)])
        (when (and tw sw)
          (let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
            (unless (equal? new-width char-width)
              (set! char-width new-width)
              (format-expr)
              (on-width-changed char-width))))))
    
    (inherit get-margin)
    (define/public (get-snip-width)
      (let ([admin (get-admin)])
        (and admin
             (let ([containing-editor (send admin get-editor)]
                   [bl (box 0)]
                   [br (box 0)])
               (send containing-editor get-snip-location this bl #f #f)
               (send containing-editor get-snip-location this br #f #t)
               (let ([outer-w (- (unbox br) (unbox bl))])
                 (let-values ([(hms vms) (get-margin-space)])
                   (- outer-w hms)))))))
    
    (define/private (get-margin-space)
      (let ([bl (box 0)]
            [br (box 0)]
            [bt (box 0)]
            [bb (box 0)])
        (get-margin bl bt br bb)
        (values (+ (unbox bl) (unbox br) 6)   ;; not sure what the 2 is for. Maybe caret space?
                (+ (unbox bt) (unbox bb)))))
    
    ;; get-width-of-char : -> number or false
    ;; depends on `dc' field
    (define/public (get-width-of-char)
      (let ([ed (get-editor)])
        (and ed
             (let ([std-style (send (editor:get-standard-style-list) find-named-style "Standard")]
                   [dc (send ed get-dc)])
               (and dc
                    (let-values ([(tw th _2 _3) (send dc get-text-extent "w"
                                                      (and std-style
                                                           (send std-style get-font)))])
                      tw))))))
    
    ;; depends on `dc' field
    (define/public (get-height-of-char)
      (let ([ed (get-editor)])
        (and ed
             (let ([dc (send ed get-dc)]
                   [std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
               (and dc
                    (let-values ([(tw th _2 _3) (send dc get-text-extent "w"
                                                      (and std-style
                                                           (send std-style get-font)))])
                      th))))))
    
    (define/pubment (on-width-changed w) (inner (void) on-width-changed w))
    
    (define/public (format-expr)
      (let* ([text (get-editor)]
             [port (open-output-text-editor text)])
        (send text begin-edit-sequence)
        (when (is-a? text color:text<%>)
          (send text thaw-colorer))
        (send text set-styles-sticky #f)
        (send text erase)
        (real-pp expr port char-width text)
        (unless (zero? (send text last-position))
          (when (char=? #\newline (send text get-character (- (send text last-position) 1)))
            (send text delete (- (send text last-position) 1) (send text last-position))))
        (when (is-a? text color:text<%>)
          (send text freeze-colorer))
        (send text end-edit-sequence)))
    
    (super-new)
    (inherit use-style-background)
    (use-style-background #t)))

(define size-text%
  (scheme:set-mode-mixin
   (scheme:text-mixin
    (color:text-mixin
     (text:autocomplete-mixin
      (mode:host-text-mixin
       (editor:standard-style-list-mixin
        text:basic%)))))))