;; Scheme side of an elisp <-> scheme reader channel.

(module emacs-channel scheme/base

  (require "util.ss"
           scheme/control
           (lib "async-channel.ss"))
  
  (provide (all-defined-out))


  ;; scheme -> emacs and emacs -> scheme are logical s-expression
  ;; channels. Raw output is not allowed. To enforce this, two tasks
  ;; will read and write to/from the emacs process using stdio.

  (define (to-emacs)
    (forever
     (let ((expr (channel-get *to-emacs*)))
       (printf "~s\n"
               (clean-for-elisp expr)))))



  ;; With emacsclient it seems to work. However, there seems to be
  ;; some maximum message length, and it isn't really fast either..

;;   (define (emacsclient-eval-str str)
;;     (define out (open-output-file "/dev/null" #:exists 'append))
;;     (let-values
;;         (((proc
;;            stdout
;;            stdin
;;            stderr) (subprocess out #f out
;;                                "/usr/bin/emacsclient" "-e" str)))
;;       (subprocess-wait proc)
;;       (close-output-port stdin)))
  
;;   (define (to-emacs)
;;     (forever
;;      (let ((expr (channel-get *to-emacs*)))
;;        (emacsclient-eval-str
;;         (format "~s"
;;                 `(snot-unserialize/eval
;;                   ',(clean-for-elisp expr)))))))
  
  (define (from-emacs)
    (let loop ()
      (let ((expr (read)))
        ;; Exit thread on EOF.  This only occurs during debugging.
        (if (eof-object? expr)
            (void)
            ;; (debug-printf "eof: from-emacs terminating\n")
            (begin
              (channel-put *from-emacs* (clean-for-scheme expr))
              (loop))))))


  ;; All s-expression communication goes through these message
  ;; channels for synchronization. they are a wrapper around the low
  ;; level character I/O.

  (define *to-emacs*    (make-channel))
  (define *from-emacs*  (make-channel))


  
  ;; Debug print bypassess 'emacs-send'
  (define (debug-printf . args)
    (channel-put *to-emacs*
                 `(snot-display ,(apply format args))))
  
  (define (emacs-receive)
    (let ((msg (channel-get *from-emacs*)))
      (when (debug) (debug-printf "<-E ~s\n" msg))
      msg))
           
  (define (emacs-send expr)
    (when (debug) (debug-printf "->E ~s\n" expr))
    (channel-put *to-emacs* expr))
  

  ;; Highlevel messages to emacs

  ;; Note that for RPC initiated from emacs, the code will perform
  ;; 'snot-unserialize, but when we send a command, we need to do it
  ;; ourselves.
;;   (define (--emacs-command cmd . args)
;;     (emacs-send `(,cmd
;;                   ,@(map
;;                      (lambda (arg)
;;                        `(snot-unserialize ',arg))))))

;;   (define (emacs-command cmd . args)
;;     (emacs-send (cons cmd args)))


  ;; Display is throttled.
  (define emacs-display-pipe (make-channel))

  (define emacs-throttle-time (make-parameter .1))
  (define emacs-throttle-size (make-parameter 4000))
  (define emacs-display-filter (make-parameter (lambda (x) x)))
  (define emacs-max-rep-output (make-parameter 10000))

  (define (emacs-update-display)
    (let collect ((strings '())
                  (size 0))
      (let ((done (lambda ()
                    (unless (null? strings)
                      (let ((aggregate
                             (apply bytes-append (reverse strings))))
                        (emacs-send `(snot-display ,aggregate))
                        ;; (display aggregate)
                        ))
                    (emacs-update-display))))
        (cond
         ((> size (emacs-throttle-size)) (done))
         ((sync/timeout (emacs-throttle-time) emacs-display-pipe) =>
          (lambda (bytes)
            (let ((nbytes (bytes-length bytes)))
              (collect (cons bytes strings)
                       (+ size nbytes)))))
         (else (done))))))

  (define (emacs-display str)
    (let ((bytes
           (or (and (string? str) (string->bytes/utf-8 str))
               (and (bytes? str)  str))))
      (let ((bytes ((emacs-display-filter) bytes)))
        (when bytes (channel-put emacs-display-pipe bytes)))))

  ;; It's possible to limit output alltogether
  (define (emacs-limit-output thunk [max (emacs-max-rep-output)])
    (define counter 0)
    (define (check bytes)
      (and counter
           (set! counter (+ counter (bytes-length bytes)))
           (if (> counter max)
               (begin
                 (set! counter #f)
                 (string->bytes/utf-8
                  (format "\n*** Output truncated at ~a bytes ***\n" max)))
               bytes)))
    (parameterize ((emacs-display-filter check))
      (thunk)))
  
  (define emacs-update-thread (thread emacs-update-display))

  


  
  (define (emacs-display-image type data)  (emacs-send `(snot-display-image ',type ,data)))
  (define (emacs-printf . a) (emacs-display (apply format a)))
  
  (define (emacs-message-printf . args)
    (emacs-send `(message ,(apply format args))))


  ;; In addition to commands and return values, code that produces
  ;; output needs to send this through the stdio pipe. All raw scheme
  ;; -> emacs output goes through this port, so it can be merged with
  ;; the other channel traffic.

  (define *log-emacs*
    (let ((out (current-output-port))) ;; FIXME
      (make-output-port
       'emacslog
       out
       (lambda (buffer start endx allow-buffer enable-breaks)
         (emacs-display
          (subbytes buffer start endx))
         (- endx start))
       (lambda ()
         (close-output-port out)))))

  

  ;; EXPRESSION TRANSLATION

  ;; Handle little differences in scheme/emacs expressions.

  (define (safe-bytes? b)
    (let ((numbers
           (bytes->list b)))
      (call/ec
       (lambda (exit)
         (for-each
          (lambda (c)
            (case c
              ((10 13 9) #t)  ;; this is ok
              (else
               (when (or (< c 32)
                         (> c 127))
                 (exit #f)))))
          numbers)
         #t))))


  (define (clean-for-elisp x)
    (cond
     ((not x) '()) ;; nil
     ((or
       (null? x)
       (symbol? x)
       (number? x)) x)
     
     ((void? x)   'void)

     ;; '(uq x)' will eval x in elisp right after receive.
     ((bytes? x)
      (if (safe-bytes? x)
          (bytes->string/utf-8 x)
          `(,'uq (string ,@(bytes->list x)))))
     
     ((string? x)
      (clean-for-elisp (string->bytes/utf-8 x)))
     
     ;; ((string? x) x)
     ((path? x)   (clean-for-elisp (path->string x)))
     ((syntax? x) (clean-for-elisp (syntax->datum x))) ;; why not..

     ((pair? x)
      (cons (clean-for-elisp (car x))
            (clean-for-elisp (cdr x))))
     (else
      (cons 'abstract (clean-for-elisp (format "~s" x))))))

  (define (clean-for-scheme x) x)


;;   (define (syntax->expr stx)
;;     (define clean-more
;;       (match-lambda
;;        (('|#%app|   . expr)  (clean-more expr))
;;        (('|#%datum| . expr)  (clean-more expr))
;;        ((car . cdr)          `(,(clean-more car) . ,(clean-more cdr)))
;;        (other                other)))
;;     (clean-more
;;      (syntax-object->datum stx)))
  

  )