(module syntax-snip mzscheme
  (require mzlib/class
           mred
           framework
           mzlib/match
           mzlib/list
           mzlib/string
           "../util/notify.ss"
           "interfaces.ss"
           "display.ss"
           "controller.ss"
           "keymap.ss"
           "properties.ss"
           "partition.ss"
           "prefs.ss")

  (provide syntax-snip%
           syntax-value-snip%)

  (define syntax-snip-config-base%
    (class object%
      (notify-methods props-shown?)
      (super-new)))
  (define syntax-snip-config%
    (class syntax-snip-config-base%
      (define/override (init-props-shown?) (new notify-box% (value #f)))
      (super-new)))

  (define dumb-host%
    (class object%
      (define controller (new controller%))
      (define config (new syntax-snip-config%))
      (super-new)
      (define/public (get-controller) controller)
      (define/public (get-config) config)
      (define/public (add-keymap text snip)
        (send text set-keymap
              (new syntax-keymap%
                   (controller controller)
                   (editor text)
                   (config config))))))

  ;; syntax-value-snip%
  (define syntax-value-snip%
    (class* editor-snip% (readable-snip<%>)
      (init-field ((stx syntax)))
      (init-field (host (new dumb-host%)))
      (inherit set-margin
               set-inset)

      (define text (new text:standard-style-list%))
      (super-new (editor text) (with-border? #f))

      (set-margin 0 0 0 0)
      ;;(set-inset 2 2 2 2)
      ;;(set-margin 2 2 2 2)
      (set-inset 0 0 0 0)

      (send text begin-edit-sequence)
      (send text change-style (make-object style-delta% 'change-alignment 'top))
      (define display
        (print-syntax-to-editor stx text (send host get-controller)))
      (send text lock #t)
      (send text end-edit-sequence)
      (send text hide-caret #t)

      (send host add-keymap text this)

      ;; snip% Methods
      (define/override (copy)
        (new syntax-value-snip% (host host) (syntax stx)))

      ;; read-special : any number/#f number/#f number/#f -> syntax
      ;; Produces 3D syntax to preserve eq-ness of syntax
      ;; #'#'stx would be lose identity when wrapped
      (define/public (read-special src line col pos)
        (with-syntax ([p (lambda () stx)])
          #'(p)))
      ))

  (define top-aligned
    (make-object style-delta% 'change-alignment 'top))

  (define-struct styled (contents style clickback))

  ;; clicky-snip%
  (define clicky-snip%
    (class* editor-snip% ()

      (init-field [open-style '(border)]
                  [closed-style '(tight-text-fit)])

      (inherit set-margin
               set-inset
               set-snipclass
               set-tight-text-fit
               show-border
               get-admin)

      (define -outer (new text%))
      (super-new (editor -outer) (with-border? #f))
      (set-margin 2 2 2 2)
      (set-inset 2 2 2 2)
      ;;(set-margin 3 0 0 0)
      ;;(set-inset 1 0 0 0)
      ;;(set-margin 0 0 0 0)
      ;;(set-inset 0 0 0 0)

      (define/public (closed-contents) null)
      (define/public (open-contents) null)

      (define open? #f)

      (define/public (refresh-contents)
        (send* -outer
          (begin-edit-sequence)
          (lock #f)
          (erase))
        (do-style (if open? open-style closed-style))
        (outer:insert (if open? (hide-icon) (show-icon))
                      style:hyper
                      (if open?
                          (lambda _
                            (set! open? #f)
                            (refresh-contents))
                          (lambda _
                            (set! open? #t)
                            (refresh-contents))))
        (for-each (lambda (s) (outer:insert s))
                  (if open? (open-contents) (closed-contents)))
        (send* -outer
          (change-style top-aligned 0 (send -outer last-position))
          (lock #t)
          (end-edit-sequence)))

      (define/private (do-style style)
        (show-border (memq 'border style))
        (set-tight-text-fit (memq 'tight-text-fit style)))

      (define/private outer:insert
        (case-lambda
         [(obj)
          (if (styled? obj)
              (outer:insert (styled-contents obj)
                            (styled-style obj)
                            (styled-clickback obj))
              (outer:insert obj style:normal))]
         [(text style)
          (outer:insert text style #f)]
         [(text style clickback)
          (let ([start (send -outer last-position)])
            (send -outer insert text)
            (let ([end (send -outer last-position)])
              (send -outer change-style style start end #f)
              (when clickback
                    (send -outer set-clickback start end clickback))))]))

      (send -outer hide-caret #t)
      (send -outer lock #t)
      (refresh-contents)
      ))

  ;; syntax-snip%
  (define syntax-snip%
    (class* clicky-snip% (readable-snip<%>)
      (init-field ((stx syntax)))
      (init-field (host (new dumb-host%)))
      (define config (send host get-config))
      (inherit set-snipclass
               refresh-contents)

      (define the-syntax-snip
        (new syntax-value-snip%
             (syntax stx)
             (host host)))
      (define the-summary
        (let* ([t (new text%)]
               [es (new editor-snip% (editor t) (with-border? #f))])
          (send es set-margin 0 0 0 0)
          (send es set-inset 0 0 0 0)
          (send t insert (format "~s" stx))
          es))

      (define properties-snip
        (new properties-container-snip%
             (controller (send host get-controller))))

      (define/override (closed-contents)
        (list the-summary))

      (define/override (open-contents)
        (list " "
              the-syntax-snip
              " "
              properties-snip))

      ;; Snip methods
      (define/override (copy)
        (new syntax-snip% (syntax stx)))
      (define/override (write stream)
        (send stream put
              (string->bytes/utf-8
               (format "~s" (marshall-syntax stx)))))
      (define/public (read-special src line col pos)
        (send the-syntax-snip read-special src line col pos))

      (send config listen-props-shown?
            (lambda (?) (refresh-contents)))

      (super-new)
      (set-snipclass snip-class)))


  (define properties-container-snip%
    (class clicky-snip%
      (init controller)

      (define properties-snip
        (new properties-snip% (controller controller)))

      (define/override (open-contents)
        (list #;(show-properties-icon)
              properties-snip))

      (define/override (closed-contents)
        (list (show-properties-icon)))

      (super-new (open-style '())
                 (closed-style '()))))

  (define style:normal (make-object style-delta% 'change-normal))
  (define style:hyper
    (let ([s (make-object style-delta% 'change-normal)])
      (send s set-delta 'change-toggle-underline)
      (send s set-delta-foreground "blue")
      s))
  (define style:green
    (let ([s (make-object style-delta% 'change-normal)])
      (send s set-delta-foreground "darkgreen")
      s))
  (define style:bold
    (let ([s (make-object style-delta% 'change-normal)])
      (send s set-delta 'change-bold)
      s))

  (define (show-icon)
    (make-object image-snip%
      (build-path (collection-path "icons") "turn-up.png")))
  (define (hide-icon)
    (make-object image-snip%
      (build-path (collection-path "icons") "turn-down.png")))

  (define (show-properties-icon)
    (make-object image-snip%
      (build-path (collection-path "icons") "syncheck.png")))

  ;; marshall-syntax : syntax -> printable
  (define (marshall-syntax stx)
    (unless (syntax? stx)
      (error 'marshall-syntax "not syntax: ~s\n" stx))
    `(syntax
      (source ,(marshall-object (syntax-source stx)))
      (source-module ,(marshall-object (syntax-source-module stx)))
      (position ,(syntax-position stx))
      (line ,(syntax-line stx))
      (column ,(syntax-column stx))
      (span ,(syntax-span stx))
      (original? ,(syntax-original? stx))
      (properties 
       ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
              (syntax-property-symbol-keys stx)))
      (contents
       ,(marshall-object (syntax-e stx)))))

  ;; marshall-object : any -> printable
  ;; really only intended for use with marshall-syntax
  (define (marshall-object obj)
    (cond
      [(syntax? obj) (marshall-syntax obj)]
      [(pair? obj) 
       `(pair ,(cons (marshall-object (car obj))
                     (marshall-object (cdr obj))))]
      [(or (symbol? obj)
           (char? obj)
           (number? obj)
           (string? obj)
           (boolean? obj)
           (null? obj))
       `(other ,obj)]
      [else (string->symbol (format "unknown-object: ~s" obj))]))

  ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
  (define syntax-snipclass%
    (class snip-class%
      (define/override (read stream)
        (make-object syntax-snip%
          (unmarshall-syntax (read-from-string (send stream get-bytes)))))
      (super-instantiate ())))

  (define snip-class (make-object syntax-snipclass%))
  (send snip-class set-version 2)
  (send snip-class set-classname
        (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
  (send (get-the-snip-class-list) add snip-class)

  (define (unmarshall-syntax stx)
    (match stx
      [`(syntax
         (source ,src)
         (source-module ,source-module) ;; marshalling
         (position ,pos)
         (line ,line)
         (column ,col)
         (span ,span)
         (original? ,original?)
         (properties ,@(properties ...))
         (contents ,contents))
        (foldl
         add-properties
         (datum->syntax-object
          #'here ;; ack
          (unmarshall-object contents)
          (list (unmarshall-object src)
                line
                col
                pos
                span))
         properties)]
      [else #'unknown-syntax-object]))
  
  ;; add-properties : syntax any -> syntax
  (define (add-properties prop-spec stx)
    (match prop-spec
      [`(,(and sym (? symbol?))
          ,prop)
        (syntax-property stx sym (unmarshall-object prop))]
      [else stx]))
  
  (define (unmarshall-object obj)
    (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
      (if (and (pair? obj)
               (symbol? (car obj)))
          (case (car obj)
            [(pair) 
             (if (pair? (cdr obj))
                 (let ([raw-obj (cadr obj)])
                   (if (pair? raw-obj)
                       (cons (unmarshall-object (car raw-obj))
                             (unmarshall-object (cdr raw-obj)))
                       (unknown)))
                 (unknown))]
            [(other) 
             (if (pair? (cdr obj))
                 (cadr obj)
                 (unknown))]
            [(syntax) (unmarshall-syntax obj)]
            [else (unknown)])
          (unknown))))

  )