;; -*- Mode: Emacs-Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: ANSI CSI Select Graphic Rendition for SLIME
;;   Created: 2023-01-13
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (c) copyright 2023 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;;;; TODO

;; We would need to support these ANSI Codes with the SLIME debugger as
;; well. For that we probably would need some stream abstraction or the
;; like.

;;;; Implementation

;; Somehow these cannot be buffer local, can they?

(require'cl)

(defvar slime-repl-output-props nil
  "The current REPL output properties.")

(defvar slime-repl-output-state nil
  "The current state of `slime-repl-emit', NIL means default state.")

(defvar slime-repl-output-stash ""
  "Cummulated string not yet emitted with `slime-repl-emit'.")

;; The strategy is that we look at a piece of output and when there is
;; any ESC inside we switch to another mode and try to make sense of the
;; escape.

;; We keep the original SLIME-REPL-EMIT with a twist: It'll use the
;; value of `slime-repl-output-face' for its face.

(defun slime-repl-emit (string)
  (let ((case-fold-search nil) p it)
    (case slime-repl-output-state
      (:esc
       (setq slime-repl-output-stash (concat slime-repl-output-stash string))
       (cond ((and (setq it (slime-repl-match-csi string))
                   (eql 0 (car it)))
              (destructuring-bind (start end dir params) it
                (slime-repl-do-csi dir params)
                (setq slime-repl-output-state nil)
                (slime-repl-emit (subseq (prog1 slime-repl-output-stash
                                           (setq slime-repl-output-stash ""))
                                         end))))
             ((string-match "^\e." string)
              ;; any other escape, just eat it
              (let ((end (match-end 0)))
                (setq slime-repl-output-state nil)
                (slime-repl-emit (subseq (prog1 slime-repl-output-stash
                                           (setq slime-repl-output-stash ""))
                                         end))))
             (t
              (message "Huh? %s" slime-repl-output-stash))))
      (t
       (cond ((setq p (string-match "\e" string))
              (slime-repl-emit-1 (subseq string 0 p))
              (setq slime-repl-output-stash "" ;just in case
                    slime-repl-output-state :esc)
              (slime-repl-emit (subseq string p)))
             ;; ((setq p (string-match "\r" string))
             ;;  (slime-repl-emit-1 (subseq string 0 p))
             ;;  (slime-repl-emit-cr)
             ;;  (slime-repl-emit (subseq string (1+ p))))
             (t
              (slime-repl-emit-1 string)))))))

(defun slime-repl-do-csi (directive params)
  (cond ((equal "m" directive)
         (setq slime-repl-output-props (slime-repl-apply-sgr-to-props params slime-repl-output-props)))))

(defun slime-repl-emit-1 (string)
  ;; The original thing but for using the value of `slime-repl-output-face'.
  ;; "insert the string STRING in the output buffer"
  (with-current-buffer (slime-output-buffer)
    (save-excursion
      (goto-char slime-output-end)
      (slime-save-marker slime-output-start
        (let ((props slime-repl-output-props))
          (setq props (copy-list props))
          (setf (getf props 'face) (append (let ((q (getf props 'face)))
                                             (if (listp q) q (list q)))
                                           '(slime-repl-output-face)))
          (setf (getf props 'rear-nonsticky) '(face display))
          (slime-propertize-region props
            (insert-before-markers string)
            (when (and (<= (point) slime-repl-prompt-start-mark) (not (bolp)))
              (insert-before-markers "\n")
              (set-marker slime-output-end (1- (point))))))))
    (when slime-repl-popup-on-output
      (setq slime-repl-popup-on-output nil)
      (display-buffer (current-buffer)))
    (slime-repl-show-maximum-output)))


;;;;

(defun sldb-insert-condition (condition)
  "Insert the text for CONDITION.
CONDITION should be a list (MESSAGE TYPE EXTRAS).
EXTRAS is currently used for the stepper."
  (destructuring-bind (message type extras) condition
    (setq message (slime-repl-deansify-string message nil))
    (slime-insert-propertized '(sldb-default-action sldb-inspect-condition)
                              message ;; (in-sldb-face topline message)
                              "\n"
                              (in-sldb-face condition type))
    (sldb-dispatch-extras extras)))

(defun slime-add-face (face string)
  ;; was: (add-text-properties 0 (length string) (list 'face face) string)
  ;; Use `add-face-text-property' to not destroy faces already present in
  ;; `string' and append those. --GB
  (add-face-text-property 0 (length string) face t string)
  string)

(defun slime-repl-match-csi (string)
  "-> (start end dir params) | NIL"
  (if (string-match "\e\\[\\([\x20-\x3F]*\\)\\(.\\)" string)
      (let ((params (match-string 1 string))
            (dir    (match-string 2 string))
            (start  (match-beginning 0))
            (end    (match-end 0)))
        (setq params (split-string params ";" t))
        (list start end dir params))
    nil))

(defun slime-repl-deansify-string (string &optional props)
  "Return a new propertized string with results from applying
ANSI escape sequences found in `string'."
  (cond ((string-match "\e\\[\\([\x20-\x3F]*\\)\\(.\\)" string)
         (let ((params (match-string 1 string))
               (dir    (match-string 2 string))
               (start  (match-beginning 0))
               (end    (match-end 0)))
           ;;
           (dolist (k (getf props 'face))
             (add-face-text-property 0 start k nil string))
           (setq params (split-string params ";" t))
           (cond ((equal dir "m")
                  (setq props (slime-repl-apply-sgr-to-props params props))))
           (concat (subseq string 0 start)
                   (slime-repl-deansify-string (subseq string end) props))))
        (t
         (dolist (k (getf props 'face))
           (add-face-text-property 0 (length string) k nil string))
         string)))

(defun slime-repl-apply-sgr-to-props (params props)
  (setq props (copy-list props))
  (unless (listp (getf props 'face))
    (setq (getf props 'face) (list (getf props 'face))))
  (dolist (p (or params '("0")))
    (let ((p (and (string-match "^[0-9]+$" p) (string-to-number p))))
      (case p
        (0 (remf props 'face)
           (remf props 'display))
        (1 (pushnew 'bold (getf props 'face)))
        ;; 2 faint
        (3 (pushnew 'italic (getf props 'face)))
        (4 (pushnew 'underline (getf props 'face)))
        ;; 5, 6 blink
        (7 (pushnew '(:inverse-video t) (getf props 'face)))
        ;; 8 hide
        ;; 9 strike-through
        (9 (pushnew '(:strike-through t) (getf props 'face) :test 'equal))
        ;; 10..19 font select (20 fraktur?)
        ;; 21 doubly underline
        ;; 22 normal intensity
        (22 (setq (getf props 'face) (remove 'bold (getf props 'face))))
        ;; 23 neither bold, black-letter (how to set black-letter and what is it?)
        (23 (setq (getf props 'face) (remove 'bold (getf props 'face))))
        ;; 24 not underlined
        (24 (setq (getf props 'face) (remove 'underline (getf props 'face))))
        ;; 25 not blinking
        ;; 26 proportional spacing
        (27 (setq (getf props 'face) (remove '(:inverse-video t) (getf props 'face))))
        ;; 28 not hidden
        ;; 29 not strike-through
        (29 (setq (getf props 'face) (remove '(:strike-through t) (getf props 'face))))
        ;; 40..37 bg
        ;; 50 disable proportional
        (51 (pushnew '(:box t) (getf props 'face) :test 'equal))
        (52 (pushnew '(:box t) (getf props 'face) :test 'equal))
        (53 (pushnew '(:overline t) (getf props 'face)) :test 'equal)
        (54 (setq (getf props 'face) (remove '(:box t) (getf props 'face))))
        (55 (setq (getf props 'face) (remove '(:overline t) (getf props 'face))))
        ;; 58 underline color
        ;; 59 default underline color
        ;; ### The subscript and superscript faces come from TeX mode.
        (73 (setq (getf props 'face) (remove 'subscript (getf props 'face)))
            (setf (getf props 'display) '(raise 0.5))
            (pushnew 'superscript (getf props 'face)))
        (74 (setq (getf props 'face) (remove 'superscript (getf props 'face)))
            (setf (getf props 'display) '(raise -0.5))
            (pushnew 'subscript (getf props 'face)))
        (75 (setq (getf props 'face) (remove 'subscript (getf props 'face)))
            (setq (getf props 'face) (remove 'superscript (getf props 'face)))
            (remf props 'display))
        (t
         (cond ((and (integerp p)
                     (or (<= 30 p 37) (<= 90 p 97)
                         (<= 40 p 47) (<= 100 p 107) ))
                (setq props (slime-repl-apply-ansi-color-to-props p props))))))))
  props)

(defun slime-repl-apply-ansi-color-to-props (code props)
  (setq props (copy-list props))
  (let ((which :foreground))
    (when (or (<= 40 code 47) (<= 100 code 107))
      (setq which :background code (- code 10)))
    (let ((value (case code 
                   (30 "#000000") (31 "#C23621") (32 "#25BC24") (33 "#ADAD27")
                   (34 "#492EE1") (35 "#D338D3") (36 "#33BBC8") (37 "#CBCCCD")
                   (90 "#818383") (91 "#FC391F") (92 "#31E722") (93 "#EAEC23")
                   (94 "#5833FF") (95 "#F935F8") (96 "#14F0F0") (97 "#E9EBEB"))))
      (setf (getf props 'face)
            (remove-if (lambda (x) (and (consp x) (eq (car x) which))) (getf props 'face)))
      (when value
        (setf (getf props 'face)
              (cons (list which value) (getf props 'face)))) ))
  props)