(module wxme mzscheme
  (require mzlib/port
           mzlib/string
           mzlib/kw
           mzlib/class
           racket/contract
           mzlib/list
           scheme/gui/dynamic
           syntax/modread
           (only racket/snip/private/snip int->img-type)
           "image.ss"
           "editor.ss"
           "private/compat.ss")

  (define (decode who port snip-filter close? skip-content?)
    (expect #rx#"^WXME" port who "does not start with \"WXME\"")
    (expect #rx#"^01" port who "unrecognized format (not \"01\")")
    (let ([vers (string->number
                 (bytes->string/latin-1
                  (expect #rx#"^0[1-8]" port who "unrecognized version")))])
      (unless (vers . < . 4)
        (expect #rx#"^ ##[ \r\n]" port who "missing \" ## \" tag in the expected place"))
      (let ([header (read-header who port vers snip-filter skip-content?)])
        (let ([port (port->decoded-port who port vers header close?)])
          (if skip-content?
              (extract-used header port)
              port)))))
  
  (define (expect rx port who msg)
    (let ([m (regexp-match rx port)])
      (unless m
        (error who "bad WXME stream; ~a" msg))
      (car m)))

  (define (extract-used header port)
    (let loop ()
      (unless (eof-object? (read-byte-or-special port))
        (loop)))
    (values
     (filter values (map (lambda (c)
                           (and (snip-class-used? c)
                                (bytes->string/latin-1 (snip-class-name c))))
                         (vector->list (header-classes header))))
     (filter values (map (lambda (c)
                           (and (data-class-used? c)
                                (bytes->string/latin-1 (data-class-name c))))
                         (vector->list (header-data-classes header))))))

  ;; ----------------------------------------
  
  (define-struct header (classes data-classes styles snip-filter skip-unknown? snips-to-go stream skip-content?))
  (define (header-plain-text? h)
    (not (header-snip-filter h)))

  (define (read-header who port vers snip-filter skip-content?)
    (let* ([classes (read-snip-class-list who port vers)]
           [data-classes (read-data-class-list who port vers)]
           [header (make-header classes 
                                data-classes
                                (make-hash-table) 
                                snip-filter 
                                (unknown-extensions-skip-enabled)
                                0
                                #f
                                skip-content?)])
      (set-header-stream! header (make-object stream% who port vers header))
      (let ([cnt (read-editor who port vers header)])
        (set-header-snips-to-go! header cnt))
      header))

  (define (read-editor who port vers header)
    (discard-headers/footers who port vers)
    (read-styles who port vers (header-styles header))
    (read-class-headers who port vers header)
    (read-integer who port vers "snip count"))

  (define (read-editor-footers who port vers header)
    (discard-headers/footers who port vers))

  (define (read-editor-snip who port vers header)
    (let ([cnt (read-editor who port vers header)])
      (let loop ([cnt cnt][accum null])
        (if (zero? cnt)
            (begin
              (read-editor-footers who port vers header)
              (if (header-plain-text? header)
                  (apply bytes-append (reverse accum))
                  (snip-results->port 'nested-editor
                                      (let ([results (reverse accum)])
                                        (lambda ()
                                          (and (pair? results)
                                               (begin0
                                                (car results)
                                                (set! results (cdr results))))))
                                      void)))
            (loop (sub1 cnt)
                  (cons (read-snip who port vers header)
                        accum))))))

  (define-struct snip-class (name version required? manager used?))

  (define (read-snip-class-list who port vers)
    (let ([cnt (read-integer who port vers "snip-class count")])
      (list->vector
       (let loop ([i 0])
         (if (= i cnt)
             null
             (cons
              (let ([name (read-a-string who port vers "snip-class name")])
                (make-snip-class name
                                 (read-integer who port vers "snip-class version")
                                 (begin (read-integer who port vers "snip-class required?")
                                        ;; required? value isn't actually used; only a few
                                        ;;  built-in classes are required
                                        (member name '(#"wxtext" #"wxtab" #"wxmedia")))
                                 #f
                                 #f))
              (loop (add1 i))))))))

  (define-struct data-class (name required? manager used?))

  (define (read-data-class-list who port vers)
    (let ([cnt (read-integer who port vers "data-class count")])
      (list->vector
       (let loop ([i 0])
         (if (= i cnt)
             null
             (cons
              (let ([name (read-a-string who port vers "data-class name")])
                (make-data-class name
                                 (equal? name #"wxloc")
                                 #f
                                 #f))
              (loop (add1 i))))))))

  (define (discard-headers/footers who port vers)
    (let ([cnt (read-fixed-integer who port vers "header/footer extension count")])
      (let loop ([i 0])
        (unless (= i cnt)
          (let ([len (read-fixed-integer who port vers "header/footer extension length")])
            (skip-data port vers len)
            (loop (add1 i)))))))

  (define (read-styles who port vers styles)
    (let ([id (read-integer who port vers "style-list id")])
      (hash-table-get styles id
                      (lambda ()
                        (let ([cnt (read-integer who port vers "style count")])
                          (let loop ([i 1])
                            (unless (= i cnt)
                              (unless ((read-integer who port vers "base-style id") . < . i)
                                (read-error who "integer less than current index" "base-style id" port))
                              (read-a-string who port vers "style name")
                              (if (zero? (read-integer who port vers "style is-join?"))
                                  (begin
                                    (read-integer who port vers "style family")
                                    (read-a-string who port vers "style face")
                                    (read-inexact who port vers "style size multiply")
                                    (read-integer who port vers "style size addition")
                                    (read-integer who port vers "style weight on")
                                    (read-integer who port vers "style weight off")
                                    (read-integer who port vers "style slant on")
                                    (read-integer who port vers "style slant off")
                                    (unless (vers . < . 5)
                                      (read-integer who port vers "style smoothing on")
                                      (read-integer who port vers "style smoothing off"))
                                    (read-integer who port vers "style underlined on")
                                    (read-integer who port vers "style underlined off")
                                    (unless (vers . < . 6)
                                      (read-integer who port vers "style size-in-pixels on")
                                      (read-integer who port vers "style size-in-pixels off"))
                                    (unless (vers . < . 3)
                                      (read-integer who port vers "style transparent on")
                                      (read-integer who port vers "style transparent off"))
                                    (read-inexact who port vers "style foreground multiply red")
                                    (read-inexact who port vers "style foreground multiply green")
                                    (read-inexact who port vers "style foreground multiply blue")
                                    (read-inexact who port vers "style background multiply red")
                                    (read-inexact who port vers "style background multiply green")
                                    (read-inexact who port vers "style background multiply blue")
                                    (read-integer who port vers "style foreground addition red")
                                    (read-integer who port vers "style foreground addition green")
                                    (read-integer who port vers "style foreground addition blue")
                                    (read-integer who port vers "style background addition red")
                                    (read-integer who port vers "style background addition green")
                                    (read-integer who port vers "style background addition blue")
                                    (read-integer who port vers "style alignment on")
                                    (read-integer who port vers "style alignment off"))
                                  (unless ((read-integer who port vers "shift-style id") . < . i)
                                    (read-error who "integer less than current index" "shift-style id" port)))
                              (loop (add1 i)))))
                        (hash-table-put! styles id id)))))

  (define (read-class-headers who port vers header)
    (let ([cnt (read-fixed-integer who port vers "class-header count")])
      (let loop ([i 0])
        (unless (= i cnt)
          (let ([pos (read-integer who port vers "class-header class index")]
                [len (read-fixed-integer who port vers "class-header length")])
            (let ([class (find-class pos header who port vers #f)])
              (if (and class
                       (object? (snip-class-manager class)))
                  (send (snip-class-manager class) read-header (snip-class-version class) (header-stream header))
                  (skip-data port vers len)))
            (loop (add1 i)))))))

  (define (read-snip who port vers header)
    (let ([pos (read-integer who port vers "snip class index")])
      (let ([class (find-class pos header who port vers #t)])
        (let ([len (and (or (not class)
                            (not (snip-class-required? class)))
                        (read-fixed-integer who port vers "snip length"))])
          (if (and class
                   (snip-class-manager class)
                   (not (and len
                             (header-skip-content? header))))
              (let ([style (read-integer who port vers "snip style index")]
                    [m (snip-class-manager class)]
                    [cvers (snip-class-version class)])
                (let ([s (if (procedure? m)
                             ;; Built-in snip class:
                             (m who port vers cvers header)
                             ;; Extension snip class:
                             (let* ([text? (header-plain-text? header)]
                                    [s (send m read-snip
                                             text?
                                             cvers
                                             (header-stream header))])
                               (if (and text?
                                        (not (bytes? s)))
                                   (error 'read-snip 
                                          "reader for ~a in text-only mode produced something other than bytes: ~e"
                                          (snip-class-name class)
                                          s)
                                   s)))])
                  (read-buffer-data who port vers header)
                  (if (header-skip-content? header)
                      #""
                      (if (bytes? s)
                          ;; Return bytes for the stream:
                          s
                          ;; Filter the non-bytes result, and then wrap it as
                          ;;  a special stream result:
                          (let ([s ((header-snip-filter header) s)])
                            (lambda (src line col pos)
                              (if (s . is-a? . readable<%>)
                                  (send s read-special src line col pos)
                                  s)))))))
              (begin
                (skip-data port vers len)
                #""))))))

  (define (read-buffer-data who port vers header)
    (let loop ()
      (let ([pos (read-integer who port vers "data-class index")])
        (unless (zero? pos)
          (let ([data-class (find-data-class pos header who port vers #t)])
            (let ([len (and (or (not data-class)
                                (not (data-class-required? data-class)))
                            (read-fixed-integer who port vers "data length"))])
              (if data-class
                  ((data-class-manager data-class) who port vers header)
                  (skip-data port vers len))))
          (loop)))))

  ;; ----------------------------------------

  (define (read-raw-string who port vers what)
    (let ([v (cond
              [(vers . >= . 8) (plain-read port)]
              [else (read-integer who port vers what)])])
      (unless (and (integer? v)
                   (exact? v)
                   (v . >= . 0))
        (read-error who "non-negative exact integer for string length" what port))
      (let ([s (cond
                [(vers . >= . 8) (plain-read port)]
                [else (read-bytes v port)])])
        (cond
         [(bytes? s) 
          (unless (= (bytes-length s) v)
            (read-error who "byte string whose length matches an integer count" what port))
          s]
         [(and (list? s)
               (andmap bytes? s))
          (let ([s (apply bytes-append s)])
            (unless (= (bytes-length s) v)
              (read-error who "list of byte strings whose total length matches an integer count" what port))
            s)]
         [else
          (read-error who "byte string or byte-string list" what port)]))))

  (define (read-a-string who port vers what)
    (let ([s (read-raw-string who port vers what)])
      (let ([len (bytes-length s)])
        (when (zero? len)
          (read-error who "non-empty raw string" what port))
        (subbytes s 0 (sub1 len)))))

  (define (read-integer who port vers what)
    (cond
     [(vers . >= . 8)
      (let ([v (plain-read port)])
        (unless (and (integer? v)
                     (exact? v)
                     (<= (- (expt 2 31)) v (expt 2 31)))
          (read-error who "exact integer between [-2^31,2^31]" what port))
        v)]
     [else
      (let ([b (read-byte port)])
        (cond
         [(not (zero? (bitwise-and b #x80)))
          (cond
           [(not (zero? (bitwise-and b #x40)))
            (cond
             [(bitwise-and b #x01)
              (let ([b (read-byte port)])
                ;; convert to signed:
                (if (b . > . 127)
                    (- b 256)
                    b))]
             [(not (zero? (bitwise-and b #x02)))
              (integer-bytes->integer (read-bytes 2 port) #t #t)]
             [else
              (integer-bytes->integer (read-bytes 4 port) #t #t)])]
           [else
            (bitwise-ior (arithmetic-shift (bitwise-and #x3F b) 8)
                         (read-byte port))])]
         [else b]))]))

  (define (read-fixed-integer who port vers what)
    (cond
     [(vers . >= . 8)
      (read-integer who port vers what)]
     [else
      (integer-bytes->integer (read-bytes 4 port)
                              #t
                              (if (vers . > . 1)
                                  #t
                                  (broken-wxme-big-endian?)))]))
      
  (define (read-inexact who port vers what)
    (cond
     [(vers . >= . 8)
      (let ([v (plain-read port)])
        (unless (and (number? v)
                     (real? v))
          (read-error who "real number" what port))
        v)]
     [else
      (floating-point-bytes->real (read-bytes 8 port)
                                  (if (vers . > . 1)
                                      #t
                                      (broken-wxme-big-endian?)))]))
      

  (define (read-error who expected what port)
    (error who "WXME format problem while reading for ~a (expected ~a) from port: ~e around position: ~a"
           what expected port
           (file-position port)))

  (define (skip-data port vers len)
    (if (vers . >= . 8)
        (let loop ([len len])
          (unless (zero? len)
            (plain-read port)
            (loop (sub1 len))))
        (read-bytes len port)))

  ;; ----------------------------------------

  (define snip-reader<%>
    (interface ()
      read-header
      read-snip))
  
  (define readable<%>
    (interface ()
      read-special))
  
  (define (find-class pos header who port vers used?)
    (define classes (header-classes header))
    (unless (< -1 pos (vector-length classes))
      (read-error who "integer less than class-list length" "class index" port))
    (let ([class (vector-ref classes pos)])
      (when used?
        (set-snip-class-used?! class #t))
      (unless (snip-class-manager class)
        (set-snip-class-manager!
         class
         (let ([name (snip-class-name class)])
           (cond
            [(member name '(#"wxtext" #"wxtab"))
             (lambda (who port vers cvers header)
               (read-integer who port vers "string-snip flags")
               (let ([s (read-raw-string who port vers "string-snip content")])
                 (cond
                  [(= cvers 1) (string->bytes/utf-8 (bytes->string/latin-1 s))]
                  [(= cvers 2)
                   ;; UTF-32!
                   (unless (zero? (remainder (bytes-length s) 4))
                     (read-error who "size of read byte string is not a multiple of 4" "string-snip content" port))
                   (let loop ([pos 0][accum null])
                     (if (= pos (bytes-length s))
                         (begin
                           (string->bytes/utf-8 (apply string (reverse accum))))
                         (loop (+ pos 4)
                               (cons (integer->char
                                      (let ([v (integer-bytes->integer (subbytes s pos (+ pos 4)) #f
                                                                       (broken-wxme-big-endian?))])
                                        (unless (or (<= 0 v #xD7FF)
                                                    (<= #xE000 v #x10FFFF))
                                          (read-error who "UTF-32 character; probably an endian order mismatch" 
                                                      "string-snip content" port))
                                        v))
                                     accum))))]
                  [(cvers . > . 2) s])))]
            [(equal? name #"wxmedia")
             (lambda (who port vers cvers header)
               (read-integer who port vers "nested-editor type")
               (read-integer who port vers "nested-editor border")
               (read-integer who port vers "nested-editor left margin")
               (read-integer who port vers "nested-editor top margin")
               (read-integer who port vers "nested-editor right margin")
               (read-integer who port vers "nested-editor bottom margin")
               (read-integer who port vers "nested-editor left inset")
               (read-integer who port vers "nested-editor top inset")
               (read-integer who port vers "nested-editor right inset")
               (read-integer who port vers "nested-editor bottom inset")
               (read-inexact who port vers "nested-editor min width")
               (read-inexact who port vers "nested-editor max width")
               (read-inexact who port vers "nested-editor min height")
               (read-inexact who port vers "nested-editor max height")
               (when (cvers . > . 1)
                 (read-integer who port vers "nested-editor tight-fit?"))
               (when (cvers . > . 2)
                 (read-integer who port vers "nested-editor alignment"))
               (when (cvers . > . 3)
                 (read-integer who port vers "use background color"))
               (let ([n (read-editor-snip who port vers header)])
                 (if (header-plain-text? header)
                     n
                     (make-object editor% n))))]
            [(equal? name #"wximage")
             (lambda (who port vers cvers header)
               (let ([filename (read-a-string who port vers "image-snip filename")]
                     [type (read-integer who port vers "image-snip type")]
                     [w (read-inexact who port vers "image-snip width")]
                     [h (read-inexact who port vers "image-snip height")]
                     [dx (read-inexact who port vers "image-snip x-offset")]
                     [dy (read-inexact who port vers "image-snip y-offset")]
                     [relative (read-integer who port vers "image-snip relative?")])
                 (let ([data
                        (and (and (equal? filename #"")
                                  (cvers . > . 1)
                                  (not (zero? type)))
                             ;; inlined image
                             (apply
                              bytes-append
                              (let ([len (read-fixed-integer who port vers "image-snip image length")])
                                (let loop ([i 0])
                                  (if (= i len)
                                      null
                                      (cons
                                       (read-raw-string who port vers "image-snip image content")
                                       (loop (add1 i))))))))])
                   (if (header-plain-text? header)
                       #"."
                       (make-object image%
                         (if data #f filename)
                         data w h dx dy
                         relative (int->img-type type))))))]
            [else
             (if (header-skip-content? header)
                 #f
                 ;; Load a manager for this snip class?
                 (let ([lib (string->lib-path (bytes->string/latin-1 name) #f)])
                   (if lib
                       (let ([mgr (dynamic-require lib 'reader)])
                         (unless (mgr . is-a? . snip-reader<%>)
                           (error who "reader provided by ~s is not an instance of snip-reader<%>" lib))
                         mgr)
                       (if (header-skip-unknown? header)
                           #f
                           (error who "cannot load snip-class reader: ~s" name)))))]))))
      class))

  (define (find-data-class pos header who port vers used?)
    (define data-classes (header-data-classes header))
    (unless (< -1 pos (vector-length data-classes))
      (read-error who "integer less than data-class-list length" "data-class index" port))
    (let ([data-class (vector-ref data-classes pos)])
      (when used?
        (set-data-class-used?! data-class #t))
      (unless (data-class-manager data-class)
        (set-data-class-manager!
         data-class
         (case (data-class-name data-class)
           [(#"wxloc") 
            (lambda (who port vers header)
              (read-inexact who port vers "location x")
              (read-inexact who port vers "location y"))]
           [else
            (if (header-skip-content? header)
                #f
                ;; Load a manager for this data class?
                (error who "cannot load data-class managers, yet"))])))
      data-class))

  (define stream%
    (class object%
      (init-field who port vers header)

      (public [rfi read-fixed-integer])
      (define (rfi what)
        (read-fixed-integer who port vers what))

      (public [ri read-integer])
      (define (ri what)
        (read-integer who port vers what))
      
      (public [rix read-inexact])
      (define (rix what)
        (read-inexact who port vers what))

      (define/public (read-raw-bytes what)
        (read-raw-string who port vers what))
      (define/public (read-bytes what)
        (read-a-string who port vers what))

      (public [rne read-editor-snip])
      (define (rne what)
        (read-editor-snip who port vers header))

      (super-new)))

  (define stream<%> (class->interface stream%))

  ;; ----------------------------------------
  
  (define lib-mapping (make-hash-table 'equal))

  (define (ok-string-element? m)
    (and (string? m)
         (regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m)
         (not (string=? m ".."))
         (not (string=? m "."))))
  
  (define (ok-lib-path? m)
    (and (pair? m)
         (eq? 'lib (car m))
         (pair? (cdr m))
         (list? m)
         (andmap ok-string-element? (cdr m))))

  (define (register-lib-mapping! str target)
    (unless (ok-lib-path? target)
      (error 'register-lib-mapping! "given target is not a valid marshalable lib path: ~s" target))
    (hash-table-put! lib-mapping str target))

  (define (string->lib-path str gui?)
    (or (let ([m (and (regexp-match #rx"^[(].*[)]$" str)
                      (let* ([p (open-input-string str)]
                             [m (read p)])
                        (and (eof-object? (read p))
                             m)))])
          (or (and (and (list? m)
                        (= (length m) 2)
                        (ok-lib-path? (car m))
                        (ok-lib-path? (cadr m)))
                   (if gui?
                       (car m)
                       (cadr m)))
              (and (and (ok-lib-path? m)
                        gui?)
                   m)))
        (and (not gui?)
             (hash-table-get lib-mapping str #f))))

  (register-compatibility-mappings! register-lib-mapping!)

  ;; ----------------------------------------

  (define plain-params
    (with-module-reading-parameterization
     (lambda ()
      (current-parameterization))))

  (define (plain-read port)
    (call-with-parameterization 
     plain-params 
     (lambda () 
       (with-handlers ([exn:fail:read? (lambda (x) 'no-good)])
         (read port)))))

  ;; ----------------------------------------

  (define (port->decoded-port who port vers header close?)
    (snip-results->port
     (object-name port)
     (lambda ()
       (let ([snips-to-go (header-snips-to-go header)])
         (cond
          [(zero? snips-to-go) 
           (read-editor-footers who port vers header)
           #f]
          [else 
           (set-header-snips-to-go! header (sub1 snips-to-go))
           (read-snip who port vers header)])))
     (if close?
         (lambda () (close-input-port port))
         void)))

  (define (snip-results->port name next-item! close)
    (define-values (r w) (make-pipe))
    (define (read-proc buffer)
      (if (char-ready? r)
          (read-bytes-avail! buffer r)
          (let ([s (next-item!)])
            (cond
             [(not s)
              (close-output-port w)
              eof]
             [(bytes? s)
              (write-bytes s w)
              (read-proc buffer)]
             [else s]))))
    (make-input-port/read-to-peek
     name
     read-proc
     #f
     close))

  ;; ----------------------------------------

  (define (skip-reader port)
    (regexp-match/fail-without-reading #rx#"^#reader[(]lib\"read.ss\"\"wxme\"[)]" port))

  (define (wxme-convert-port port close? snip-filter)
    ;; read optional #reader header:
    (skip-reader port)
    ;; decode:
    (decode 'read-bytes port snip-filter close? #f))

  ;; ----------------------------------------

  (define unknown-extensions-skip-enabled (make-parameter #f))

  (define broken-wxme-big-endian? (make-parameter (system-big-endian?)))

  (define (is-wxme-stream? p)
    (and (regexp-match-peek #rx#"^(?:#reader[(]lib\"read[.]ss\"\"wxme\"[)])?WXME01[0-9][0-9] ##[ \r\n]" p)
         #t))

  (define/kw (wxme-port->port port #:optional [close? #t] [snip-filter (lambda (x) x)])
    (wxme-convert-port port close? snip-filter))

  (define/kw (wxme-port->text-port port #:optional [close? #t])
    (wxme-convert-port port close? #f))

  (define (do-read orig-port who read)
    (let ([port (if (gui-available?)
                    ;; GUI mode, since GRacket is available:
                    (let ([text% (dynamic-require 'mred 'text%)]
                          [open-input-text-editor (dynamic-require 'mred 'open-input-text-editor)])
                      (let ([t (new text%)])
                        (send t insert-port orig-port 'standard)
                        (open-input-text-editor t 0 'end values (object-name orig-port) #t)))
                    ;; Non-GUI mode:
                    (decode who orig-port (lambda (x) x) #f #f))])
      ;; Turn on line counting if it was on before:
      (let-values ([(line col pos) (port-next-location orig-port)])
        (when line (port-count-lines! port)))
      ;; Read:
      (let ([v (read port)])
        (let ([v2 (let loop ()
                    (let ([v2 (read port)])
                      (if (special-comment? v2)
                          (loop)
                          v2)))])
          (if (eof-object? v2)
              v
              `(begin
                 ,@(list* v v2 (let loop ([accum null])
                                 (let ([v (read port)])
                                   (cond
                                    [(eof-object? v) (reverse accum)]
                                    [(special-comment? v) (loop accum)]
                                    [else (loop (cons v accum))]))))))))))

  (define (wxme-read port)
    (do-read port 'read read))

  (define (wxme-read-syntax source-name-v port)
    (datum->syntax-object
     #f
     (do-read port 'read-syntax
              (lambda (port)
                (read-syntax source-name-v port)))))

  (define (extract-used-classes port)
    (if (is-wxme-stream? port)
        (begin
          (skip-reader port)
          (decode 'extract-used-classes port (lambda (x) x) #f #t))
        (values null null)))

  (provide/contract [is-wxme-stream? (input-port? . -> . any)]
                    [wxme-port->text-port (->* (input-port?) (any/c) input-port?)]
                    [wxme-port->port (->* (input-port?) (any/c (any/c . -> . any)) input-port?)]
                    [register-lib-mapping! (string? string? . -> . void?)]
                    [string->lib-path (string? any/c . -> . any)]
                    [extract-used-classes (input-port? . -> . any)])

  (provide unknown-extensions-skip-enabled
           broken-wxme-big-endian?
           snip-reader<%>
           readable<%>
           stream<%>
           wxme-read
           wxme-read-syntax))