#lang scheme/base

(require "mzrl.rkt" scheme/list scheme/file)

;; --------------------------------------------------------------------------
;; Configuration

(define current-prompt   (make-parameter #"> "))
(define max-history      (make-parameter 100))
(define keep-duplicates  (make-parameter #f))
(define keep-blanks      (make-parameter #f))
(provide current-prompt max-history keep-duplicates keep-blanks)

;; --------------------------------------------------------------------------
;; Simple namespace-based completion

;; efficiently convert symbols to byte strings
(define symbol->bstring
  (let ([t (make-weak-hash)])
    (lambda (sym)
      (or (hash-ref t sym #f)
          (let ([bstr (string->bytes/utf-8 (symbol->string sym))])
            (hash-set! t sym bstr)
            bstr)))))

;; get a list of byte strings for current bindings, cache last result
(define get-namespace-bstrings
  (let ([last-syms #f] [last-bstrs #f])
    (lambda ()
      (let ([syms (namespace-mapped-symbols)])
        (unless (equal? syms last-syms)
          (set! last-syms syms)
          (set! last-bstrs (sort (map symbol->bstring syms) bytes<?)))
        last-bstrs))))

(define (namespace-completion pat)
  (let* ([pat (if (string? pat) (string->bytes/utf-8 pat) pat)]
         [pat (regexp-quote pat)]
         [pat (regexp-replace* #px#"(\\w)\\b" pat #"\\1\\\\w*")]
         [pat (byte-pregexp (bytes-append #"^" pat))])
    (filter (lambda (bstr) (regexp-match pat bstr))
            (get-namespace-bstrings))))

(set-completion-function! namespace-completion)

;; --------------------------------------------------------------------------
;; History management
;; (Note: local-history, and the preference are in reverse order, from
;; the newest to the oldest.)

(define local-history '())

(define (trim-local-history)
  (when ((length local-history) . > . (max-history))
    (set! local-history (take local-history (max-history)))))

(define (load-history)
  (set! local-history (get-preference 'readline-input-history (lambda () null)))
  (trim-local-history)
  (for-each add-history (reverse local-history)))
;; add it now to the actual history
(load-history)

(define (save-history)
  (put-preferences '(readline-input-history) (list local-history)))

(define (add-to-history s force-keep?)
  (define keep (or force-keep? (keep-duplicates)))
  (when (and (bytes? s) (or (keep-blanks) (not (zero? (bytes-length s)))))
    ;; remove duplicate (keep-blanks determines how we search)
    (unless (or (null? local-history) (eq? #t keep))
      (let ([dup (let loop ([n -1] [h local-history] [r '()])
                   (cond [(null? h) #f]
                         [(equal? (car h) s) `(,n ,@(reverse r) ,@(cdr h))]
                         [(eq? keep 'unconsecutive) #f] ; no loop
                         [else (loop (sub1 n) (cdr h) (cons (car h) r))]))])
        (when dup
          (set! local-history (cdr dup))
          (history-delete (car dup)))))
    (add-history-bytes s)
    (let loop ()
      (when ((history-length) . > . (max-history)) (history-delete 0) (loop)))
    (set! local-history (cons s local-history))
    (trim-local-history)))

;; remove `l' items from `local-history', ignoring ones that are not
;; in the front of the history (in the eq? sense)
(define (drop-from-history l)
  (let loop ([l l] [h local-history])
    (if (and (pair? l) (pair? h))
      (if (eq? (car l) (car h))
        (begin (history-delete -1) (loop (cdr l) (cdr h)))
        (loop (cdr l) h))
      (set! local-history h))))

;; captured now so we don't flush some other output port
(define readline-output-port (current-output-port))
(port-count-lines! readline-output-port)

(define (readline-bytes/hist p force-keep?)
  (when (eq? readline-output-port (current-output-port))
    (let-values ([(line col pos) (port-next-location readline-output-port)])
      (when (and col (positive? col)) (newline readline-output-port))))
  (let ([s (readline-bytes p)]) (add-to-history s force-keep?) s))

(exit-handler
 (let ([old (exit-handler)])
   (lambda (v) (save-history) (old v))))

;; --------------------------------------------------------------------------
;; An input port that goes through readline

;; readline-prompt can be
;;   #f: no prompt (normal state),
;;   <bytes>: a prompt to use
;;   'space: a prompt has been used, now use spaces instead
;;           (from readline-prompt-spaces)
;; this also controls saving multi-line histories: when the prompt is #f we
;; collect history as usual; otherwise, we accumulate the lines in a chunk (and
;; add them to the history without removing duplicates) and at the beginning of
;; each new chunk (when we read a line with a prompt that is not 'space) we
;; throw away the intermediate history lines that were added and add the whole
;; chunk as one big multiline string.
(provide readline-prompt)
(define readline-prompt (make-parameter #f))

(define-struct readline-state (prompt-spaces multiline-chunk)
  #:mutable)

(define readline-state-cell (make-thread-cell #f))
(define (get-readline-state)
  (or (thread-cell-ref readline-state-cell)
      (let ([state (readline-state #"  " '())])
        (thread-cell-set! readline-state-cell state)
        state)))

(define (do-multiline-chunk state)
  (let ([chunk (readline-state-multiline-chunk state)])
    (when (pair? chunk)
      (drop-from-history chunk)
      (add-to-history (apply bytes-append (reverse chunk)) #f)
      (set-readline-state-multiline-chunk! state '()))))

(define (readline-bytes/multiline-chunk prompt state)
  (let ([line (readline-bytes/hist prompt #t)])
    (when (and (bytes? line) (not (zero? (bytes-length line))))
      (let ([c (readline-state-multiline-chunk state)])
        (set-readline-state-multiline-chunk!
         state
         (if (pair? c)
             (list* line (readline-state-prompt-spaces state) #"\n" c)
             (cons line c)))))
    line))

(define (do-one-line state k)
  (let ([p (readline-prompt)])
    (case p
      [(#f) (thread (lambda ()
                      (do-multiline-chunk state) 
                      (k (readline-bytes/hist #"" #f))))]
      [(space) (thread
                (lambda ()
                  (k (readline-bytes/multiline-chunk (readline-state-prompt-spaces state)
                                                     state))))]
      [else (readline-prompt 'space) ; use spaces next time
            (thread
             (lambda ()
               (do-multiline-chunk state)
               (unless (= (bytes-length (readline-state-prompt-spaces state))
                          (bytes-length p))
                 (set-readline-state-prompt-spaces! 
                  state
                  (make-bytes (bytes-length p) 32)))
               (k (readline-bytes/multiline-chunk p state))))])))

(provide readline-input)
(define readline-input
  (let ([buffer  #f]
        [evt     #f]
        [skip    #f]
        [blen    #f]
        [closed? #f]
        [LF      (bytes-ref #"\n" 0)])
    (define (close!) (set! closed? #t) (save-history))
    (define (reader tgt)
      (let loop ()
        (cond [closed? eof]
              [(eof-object? buffer) (set! buffer #f) eof]
              [evt evt]
              [(not buffer)
               (set! evt
                     (wrap-evt
                      (do-one-line
                       (get-readline-state)
                       (lambda (buf)
                         (if (eof-object? buf)
                             (save-history)
                             (begin 
                               (set! skip 0)
                               (set! blen (bytes-length buf))))
                         (set! buffer buf)
                         (set! evt #f)))
                      (lambda (v) 0)))
               evt]
              [else
               ;; copy bytes
               (let ([tgtlen (bytes-length tgt)]
                     [left (- blen skip)])
                 (cond [(< tgtlen left) ; not enough target space
                        (let ([end (+ skip tgtlen)])
                          (bytes-copy! tgt 0 buffer skip end)
                          (set! skip end)
                          tgtlen)]
                       [(= tgtlen left) ; enough room for text but no newline
                        (bytes-copy! tgt 0 buffer skip blen)
                        (set! skip blen)
                        left]
                       [else ; enough room for text with newline
                        (bytes-copy! tgt 0 buffer skip blen)
                        (bytes-set! tgt left LF)
                        (set! buffer #f)
                        (add1 left)]))])))
    (make-input-port 'readline-input reader #f close!)))

;; --------------------------------------------------------------------------
;; Reading functions

;; a function that can be used for current-prompt-read
(provide read-cmdline-syntax)
(define (read-cmdline-syntax)
  (define prompt (current-prompt))
  (flush-output)
  ;; needs to set `readline-prompt' to get a prompt when reading
  (parameterize ([readline-prompt prompt])
    (let ([in ((current-get-interaction-input-port))])
      (unless (eq? 'readline-input (object-name in))
        ;; not the readline port -- print the prompt (changing the
        ;; readline-prompt and using read-complete-syntax below should still
        ;; work fine)
        (display prompt) (flush-output))
      (begin0 ((current-read-interaction) (object-name in) in)
              (do-multiline-chunk (get-readline-state))))))

