(module pretty-snip mzscheme
  (require (lib "list.ss")
           (lib "class.ss")
           (lib "pretty.ss")
           (lib "mred.ss" "mred")
           "pretty-helper.ss"
           "interfaces.ss")
  (provide (all-defined))

  ;; A range contains
  ;;   - obj : datum, stand-in for syntax object
  ;;   - start : number
  ;;   - end : number
  (define-struct range (obj start end))
  
  ;; ranges%
  (define ranges%
    (class* object% (range<%>)
      (define starts (make-hash-table))
      (define ranges (make-hash-table))
      
      (define/public (get-start obj)
        (hash-table-get starts obj (lambda _ #f)))
      (define/public (get-ranges obj)
        (hash-table-get ranges obj (lambda _ null)))
      
      (define/public (all-ranges)
        (quicksort 
         (apply append 
                (hash-table-map
                 ranges
                 (lambda (k vs)
                   (map (lambda (v) (make-range k (car v) (cdr v))) vs))))
         (lambda (x y)
           (>= (- (range-end x) (range-start x))
               (- (range-end y) (range-start y))))))
      
      (define/public (set-start obj n)
        (hash-table-put! starts obj n))
      (define/private (set-ranges obj x)
        (hash-table-put! ranges obj x))
      (define/public (add-range obj range)
        (set-ranges obj (cons range (get-ranges obj))))
      
      (super-new)))

  ;; syntax-pp%
  (define syntax-pp%
    (class* object% (syntax-pp<%>)
      (init-field main-stx)
      (init-field typesetter)
      (init-field (columns 80))
      (unless (syntax? main-stx)
        (error 'syntax-snip% "got non-syntax object"))
      
      (define-values (datum ht:flat=>stx ht:stx=>flat)
        (syntax->datum/tables main-stx))
      (define identifier-list
        (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))
      (define range (new ranges%))

      (define/public (get-range) range)
      (define/public (get-identifier-list) identifier-list)
      (define/public (flat=>stx obj)
        (hash-table-get ht:flat=>stx obj))
      (define/public (stx=>flat obj)
        (hash-table-get ht:stx=>flat obj))
      
      (define (pretty-print-syntax)
        (define (pp-pre-hook obj port)
          (send range set-start obj (send typesetter get-current-position)))
        (define (pp-post-hook obj port)
          (let ([start (send range get-start obj)]
                [end (send typesetter get-current-position)])
            (when start
              (send range add-range
                    (flat=>stx obj)
                    (cons start end)))))
        (define (pp-size-hook obj display-like? port)
          (cond [(syntax-dummy? obj)
                 (let ((ostring (open-output-string)))
                   ((if display-like? display write) (syntax-dummy-val obj) ostring)
                   (string-length (get-output-string ostring)))]
                [else #f]))
        (define (pp-print-hook obj display-like? port)
          (cond [(syntax-dummy? obj)
                 ((if display-like? display write) (syntax-dummy-val obj) port)]
                [else 
                 (error 'pretty-print-hook "unexpected special value: ~e" obj)]))
        (define (pp-extend-style-table)
          (let* ([ids identifier-list]
                 [syms (map (lambda (x) (stx=>flat x)) ids)]
                 [like-syms (map syntax-e ids)])
            (pretty-print-extend-style-table (pretty-print-current-style-table)
                                             syms
                                             like-syms)))
        
        (parameterize 
            ([pretty-print-pre-print-hook pp-pre-hook]
             [pretty-print-post-print-hook pp-post-hook]
             [pretty-print-size-hook pp-size-hook]
             [pretty-print-print-hook pp-print-hook]
             [pretty-print-columns columns]
             [pretty-print-current-style-table (pp-extend-style-table)])
          (pretty-print datum (send typesetter get-output-port))
          (send typesetter finish this)))
      (super-new)
      (pretty-print-syntax)
      ))

  (define string-typesetter%
    (class* object% (typesetter<%>)
      (define out (open-output-string))
      (define/public (get-output-port) out)
      (define/public (get-current-position)
        (string-length (get-output-string out)))
      (define/public (finish syntax-pp)
        (display (get-output-string out)))
      (super-new)))
  
  (define snip-typesetter%
    (class* editor-snip% (typesetter<%>)
      ;; controller : syntax-pp-controller<%>
      (init-field controller)
      
      (define output-text (make-object text%))
      (define output-port (make-text-port output-text))
      
      (define/public (get-output-port) output-port)
      (define/public (get-current-position)
        (send output-text last-position))
      
      (super-new (editor output-text)
                 (with-border? #f)
                 (left-margin 3)
                 (top-margin 0)
                 (right-margin 0)
                 (bottom-margin 0)
                 (left-inset 1)
                 (top-inset 0)
                 (right-inset 0)
                 (bottom-inset 0))
      
      (define/public (finish syntax-pp)
        (send output-text change-style
              (make-object style-delta% 'change-family 'modern)
              0
              (send output-text last-position))
        (for-each
         (lambda (range)
           (let* ([stx (range-obj range)]
                  [start (range-start range)]
                  [end (range-end range)])
             (when (syntax? stx)
               (send output-text set-clickback start end 
                     (lambda (_1 _2 _3)
                       (send controller on-select-syntax this stx))))))
         (send (send syntax-pp get-range) all-ranges))
        (send output-text hide-caret #t)
        (send output-text lock #t))
      ))

  ;; make-text-port : text -> port
  ;; builds a port from a text object. 
  (define (make-text-port text)
    (make-output-port #f
                      always-evt
                      (lambda (s start end flush? enable-break?)
                        (send text insert 
                              (substring (bytes->string/utf-8 s) start end)
                              (send text last-position)
                              (send text last-position))
                        (- end start))
                      void))
  
  )