(cl:in-package #:cl-user)

(defpackage #:mfa-tool.editor-color-theme
  (:use #:cl)
  (:export #:all-color-themes
           #:color-theme-args
           #:color-theme
           #:define-color-theme
           #:remove-color-theme
           #:zenburn-paren-colors))

(in-package #:mfa-tool.editor-color-theme)

;;; Configuration

(defvar *foreground-color* nil)

(defvar *background-color* nil)

(defconstant +default-parenthesis-font-face-colours+ '(:red :black :darkgreen :darkorange3 :blue :purple))

;;; Implementation

(defvar *all-color-themes* (make-hash-table :test 'string=))

(defun all-color-themes ()
  (loop for key being the hash-keys in *all-color-themes*
        collect key))

(defun color-theme-data (theme-name)
  (multiple-value-bind (color-theme-data found?)
      (gethash theme-name *all-color-themes*)
    (if found?
        color-theme-data
        (error "No color theme named ~s found." theme-name))))

(defun color-theme-super-theme-names (theme-name)
  (first (color-theme-data theme-name)))

(defun color-theme-args (theme-name)
  (rest (color-theme-data theme-name)))

(defvar *all-editor-panes* (make-hash-table :test 'eq
                                            :weak-kind :key))

(defun update-editor-pane (pane)
  (setf (capi:simple-pane-foreground pane) (or *foreground-color* :color_windowtext))
  (setf (capi:simple-pane-background pane) (or *background-color* :color_window))

  (let ((recolorize-p (editor::buffer-font-lock-mode-p (capi:editor-pane-buffer pane))))
    (when recolorize-p
      (gp:invalidate-rectangle pane)))
  (values))

(defun update-editor-panes ()
  (maphash #'(lambda (pane value)
               (declare (ignore value))
               (update-editor-pane pane))
           *all-editor-panes*)
  (values))

(defvar *editor-face-names*
  '(:region
    :show-point-face
    :interactive-input-face
    :highlight
    :non-focus-complete-face
    :font-lock-function-name-face
    :font-lock-comment-face
    :font-lock-type-face
    :font-lock-variable-name-face
    :font-lock-string-face
    :font-lock-keyword-face
    :font-lock-builtin-face
    :compiler-note-highlight
    :compiler-warning-highlight
    :compiler-error-highlight
    ))

(defun set-color-theme (theme-name)
  (destructuring-bind (&rest color-theme-args
                       &key foreground background &allow-other-keys)
      (color-theme-args theme-name)

    (setf *foreground-color* (or foreground :color_windowtext))
    (setf *background-color* (or background :color_window))

    (lw:when-let (parenthesis-colors
                  (getf color-theme-args :parenthesis-font-face-colours
                        +default-parenthesis-font-face-colours+))
      (editor::set-parenthesis-colours parenthesis-colors))

    (dolist (name *editor-face-names*)
      (let* ((color-theme-args-for-face (getf color-theme-args name))
             (face-name (intern (string name) '#:editor))
             (face (editor:make-face face-name :if-exists t)))
        (apply 'editor:make-face face-name :if-exists :overwrite
                                           :documentation (or (getf color-theme-args-for-face :documentation)
                                                              (slot-value face 'documentation))
                                           color-theme-args-for-face))))

  theme-name)

(defun color-theme (theme-name)
  (mapc 'set-color-theme (color-theme-super-theme-names theme-name))
  (set-color-theme theme-name)

  (update-editor-panes)

  theme-name)

(defun define-color-theme (theme-name super-theme-names
                           &rest color-theme-args &key &allow-other-keys)
  (dolist (super-theme-name super-theme-names)
    (multiple-value-bind (color-theme-data found?)
        (gethash super-theme-name *all-color-themes*)
      (declare (ignore color-theme-data))
      (unless found?
        (warn "Inherited color theme ~s not defined." super-theme-name))))

  (setf (gethash theme-name *all-color-themes*) (list* super-theme-names color-theme-args))

  theme-name)

(defun remove-color-theme (theme-name)
  (remhash theme-name *all-color-themes*))

(sys::without-warning-on-redefinition
  (defmethod initialize-instance :around ((pane capi:editor-pane) &key &allow-other-keys)
    (multiple-value-prog1
        (call-next-method)

      (setf (gethash pane *all-editor-panes*) pane)

      (when *foreground-color*
        (setf (capi:simple-pane-foreground pane) *foreground-color*))
      (when *background-color*
        (setf (capi:simple-pane-background pane) *background-color*))))
  )

;; This makes it "work" after the podium is launched
(defun is-editor-pane-p (obj)
  (and (typep obj 'capi:editor-pane)
       (not (eq obj (hcl:class-prototype (class-of obj))))))

(defun cache-existing-pane (pane)
  (setf (gethash pane *all-editor-panes*) pane))

(defun cache-if-pane (obj)
  (when (is-editor-pane-p obj)
    (cache-existing-pane obj)))

#+:lispworks-personal-edition
(hcl:sweep-all-objects #'cache-if-pane)


;;; Initial color themes

(define-color-theme "default" ()
  :foreground nil :background nil
  :region '(:foreground :color_highlighttext
            :background :color_highlight)
  :show-point-face '(:background :green)
  :interactive-input-face '(:foreground :red3)
  :highlight '(:bold-p t)
  :non-focus-complete-face '(:background :tweak_background)
  :font-lock-function-name-face '(:foreground :blue)
  :font-lock-comment-face '(:foreground :firebrick)
  :font-lock-type-face '(:foreground :forestgreen)
  :font-lock-variable-name-face '(:foreground :darkgoldenrod)
  :font-lock-string-face '(:foreground :rosybrown)
  :font-lock-keyword-face '(:foreground :purple)
  :font-lock-builtin-face '(:foreground :orchid)
  :compiler-note-highlight '(:foreground :magenta)
  :compiler-warning-highlight '(:foreground :orange3)
  :compiler-error-highlight '(:foreground :red))

(define-color-theme "plain" ()
  :foreground nil :background nil
  :region '(:foreground :color_highlighttext
            :background :color_highlight)
  :show-point-face '()
  :interactive-input-face '()
  :highlight '(:bold-p t)
  :non-focus-complete-face '(:background :tweak_background)
  :font-lock-function-name-face '()
  :font-lock-comment-face '()
  :font-lock-type-face '()
  :font-lock-variable-name-face '()
  :font-lock-string-face '()
  :font-lock-keyword-face '()
  :font-lock-builtin-face '()
  :compiler-note-highlight '()
  :compiler-warning-highlight '()
  :compiler-error-highlight '())

(define-color-theme "emacs" ()
  :foreground nil :background nil
  :region '(:foreground :color_highlighttext
            :background :color_highlight)
  :show-point-face '(:background :green)
  :interactive-input-face '(:foreground :red3)
  :highlight '(:bold-p t)
  :non-focus-complete-face '(:background :tweak_background)
  :font-lock-function-name-face '(:foreground :blue)
  :font-lock-comment-face '(:foreground :gray40)
  :font-lock-type-face '(:foreground :forestgreen)
  :font-lock-variable-name-face '(:foreground :darkgoldenrod)
  :font-lock-string-face '(:foreground :rosybrown)
  :font-lock-keyword-face '(:foreground :purple)
  :font-lock-builtin-face '(:foreground :orchid)
  :compiler-note-highlight '(:foreground :magenta)
  :compiler-warning-highlight '(:foreground :orange3)
  :compiler-error-highlight '(:foreground :red))

(define-color-theme "torte" ()
  :foreground (color:make-rgb 0.8s0 0.8s0 0.8s0)
  :background (color:make-rgb 0.0s0 0.0s0 0.0s0)
  :region '(:foreground :color_highlighttext
            :background :color_highlight)
  :show-point-face `(:background ,(color:make-rgb 0.6275s0 0.1255s0 0.9412s0))
  :interactive-input-face '(:foreground :pink)
  :highlight '(:bold-p t)
  :non-focus-complete-face '(:background :tweak_background)
  :font-lock-function-name-face `(:foreground ,(color:make-rgb 0.0s0 1.0s0 1.0s0))
  :font-lock-comment-face `(:foreground ,(color:make-rgb 0.5s0 0.6275s0 1.0s0))
  :font-lock-type-face `(:foreground ,(color:make-rgb 0.5s0 1.0s0 0.5s0))
  :font-lock-variable-name-face `(:foreground ,(color:make-rgb 1.0s0 1.0s0 1.0s0))
  :font-lock-string-face `(:foreground ,(color:make-rgb 1.0s0 0.6275s0 0.6275s0))
  :font-lock-keyword-face `(:foreground ,(color:make-rgb 1.0s0 1.0s0 0.0s0))
  :font-lock-builtin-face `(:foreground ,(color:make-rgb 1.0s0 1.0s0 0.0s0))
  :compiler-note-highlight '(:foreground :magenta)
  :compiler-warning-highlight '(:foreground :orange)
  :compiler-error-highlight '(:foreground :red))


(defun make-rgb (red green blue &optional alpha)
  (color:make-rgb (/ red 255s0)
                  (/ green 255s0)
                  (/ blue 255s0)
                  (and alpha (/ alpha 255s0))))

(defvar *solarized-color-table*
  '(:solarized-base03  (#x00 #x2b #x36)
    :solarized-base02  (#x07 #x36 #x42)
    :solarized-base01  (#x58 #x6e #x75)
    :solarized-base00  (#x65 #x7b #x83)
    :solarized-base0   (#x83 #x94 #x96)
    :solarized-base1   (#x93 #xa1 #xa1)
    :solarized-base2   (#xee #xe8 #xd5)
    :solarized-base3   (#xfd #xf6 #xe3)
    :solarized-yellow  (#xb5 #x89 #x00)
    :solarized-orange  (#xcb #x4b #x16)
    :solarized-red     (#xdc #x32 #x2f)
    :solarized-magenta (#xd3 #x36 #x82)
    :solarized-violet  (#x6c #x71 #xc4)
    :solarized-blue    (#x26 #x8b #xd2)
    :solarized-cyan    (#x2a #xa1 #x98)
    :solarized-green   (#x85 #x99 #x00)))

(loop for list on *solarized-color-table* by #'cddr
      for name = (first list)
      for rgb = (second list)
      do
         (color:define-color-alias
             name
             (apply #'make-rgb rgb)))

(define-color-theme "solarized-light" ()
  :foreground :solarized-base00
  :background :solarized-base3
  :region '(:foreground :solarized-base1
            :background :solarized-base3
            :inverse-p t)
  :highlight '(:background :solarized-base2)
  :font-lock-function-name-face '(:foreground :solarized-blue)
  :font-lock-comment-face '(:foreground :solarized-base1 :italic-p t)
  :font-lock-type-face '(:foreground :solarized-yellow)
  :font-lock-variable-name-face '(:foreground :solarized-blue)
  :font-lock-string-face '(:foreground :solarized-cyan)
  :font-lock-keyword-face '(:foreground :solarized-green)
  :font-lock-builtin-face '(:foreground :solarized-green)
  :compiler-note-highlight '(:foreground :solarized-green
                             :bold-p t)
  :compiler-warning-highlight '(:foreground :solarized-orange
                                :bold-p t)
  :compiler-error-highlight '(:foreground :solarized-red
                              :inverse-p t)
  :show-point-face '(:foreground :solarized-cyan
                     :bold-p t :inverse-p t)
  :interactive-input-face '(:foreground :solarized-red)
  :non-focus-complete-face '(:background :solarized-base3)
  :parenthesis-font-face-colours '(:solarized-red
                                   :solarized-base01
                                   :solarized-green
                                   :solarized-orange
                                   :solarized-blue
                                   :solarized-magenta))

(define-color-theme "solarized-dark" ()
  :foreground :solarized-base0
  :background :solarized-base03
  :region '(:foreground :solarized-base01
            :background :solarized-base03
            :inverse-p t)
  :highlight '(:background :solarized-base02)
  :font-lock-function-name-face '(:foreground :solarized-blue)
  :font-lock-comment-face '(:foreground :solarized-base01 :italic-p t)
  :font-lock-type-face '(:foreground :solarized-yellow)
  :font-lock-variable-name-face '(:foreground :solarized-blue)
  :font-lock-string-face '(:foreground :solarized-cyan)
  :font-lock-keyword-face '(:foreground :solarized-green)
  :font-lock-builtin-face '(:foreground :solarized-green)
  :compiler-note-highlight '(:foreground :solarized-green
                             :bold-p t)
  :compiler-warning-highlight '(:foreground :solarized-orange
                                :bold-p t)
  :compiler-error-highlight '(:foreground :solarized-red
                              :inverse-p t)
  :show-point-face '(:foreground :solarized-cyan
                     :bold-p t :inverse-p t)
  :interactive-input-face '(:foreground :solarized-red)
  :non-focus-complete-face '(:background :solarized-base03)
  :parenthesis-font-face-colours '(:solarized-red
                                   :solarized-base1
                                   :solarized-green
                                   :solarized-orange
                                   :solarized-blue
                                   :solarized-magenta))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun hex->color (hex)
    (declare (optimize (speed 3) (safety 1) (debug 1)))
    (check-type hex (string 7))
    (flet ((extract-digits (string start end)
             (check-type string (simple-string 7))
             (parse-integer string
                            :start start
                            :end end
                            :radix 16)))
      (let* ((hex (coerce hex 'simple-string))
             (r (extract-digits hex 1 3))
             (g (extract-digits hex 3 5))
             (b (extract-digits hex 5 7)))
        (color:make-rgb (/ r 255.0)
                        (/ g 255.0)
                        (/ b 255.0))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter +zenburn-colors+
    `((zenburn-fg+2 ,(hex->color "#FFFFEF"))
      (zenburn-fg+1 ,(hex->color "#F5F5D6"))
      (zenburn-fg ,(hex->color "#DCDCCC"))
      (zenburn-fg-1 ,(hex->color "#A6A689"))
      (zenburn-fg-2 ,(hex->color "#656555"))
      (zenburn-black ,(hex->color "#000000"))
      (zenburn-bg-2 ,(hex->color "#000000"))
      (zenburn-bg-1 ,(hex->color "#111112"))
      (zenburn-bg-05 ,(hex->color "#383838"))
      (zenburn-bg ,(hex->color "#2A2B2E"))
      (zenburn-bg+05 ,(hex->color "#494949"))
      (zenburn-bg+1 ,(hex->color "#4F4F4F"))
      (zenburn-bg+2 ,(hex->color "#5F5F5F"))
      (zenburn-bg+3 ,(hex->color "#6F6F6F"))
      (zenburn-red+2 ,(hex->color "#ECB3B3"))
      (zenburn-red+1 ,(hex->color "#DCA3A3"))
      (zenburn-red ,(hex->color "#CC9393"))
      (zenburn-red-1 ,(hex->color "#BC8383"))
      (zenburn-red-2 ,(hex->color "#AC7373"))
      (zenburn-red-3 ,(hex->color "#9C6363"))
      (zenburn-red-4 ,(hex->color "#8C5353"))
      (zenburn-red-5 ,(hex->color "#7C4343"))
      (zenburn-red-6 ,(hex->color "#6C3333"))
      (zenburn-orange ,(hex->color "#DFAF8F"))
      (zenburn-yellow ,(hex->color "#F0DFAF"))
      (zenburn-yellow-1 ,(hex->color "#E0CF9F"))
      (zenburn-yellow-2 ,(hex->color "#D0BF8F"))
      (zenburn-green-5 ,(hex->color "#2F4F2F"))
      (zenburn-green-4 ,(hex->color "#3F5F3F"))
      (zenburn-green-3 ,(hex->color "#4F6F4F"))
      (zenburn-green-2 ,(hex->color "#5F7F5F"))
      (zenburn-green-1 ,(hex->color "#6F8F6F"))
      (zenburn-green ,(hex->color "#7F9F7F"))
      (zenburn-green+1 ,(hex->color "#8FB28F"))
      (zenburn-green+2 ,(hex->color "#9FC59F"))
      (zenburn-green+3 ,(hex->color "#AFD8AF"))
      (zenburn-green+4 ,(hex->color "#BFEBBF"))
      (zenburn-cyan ,(hex->color "#93E0E3"))
      (zenburn-blue+3 ,(hex->color "#BDE0F3"))
      (zenburn-blue+2 ,(hex->color "#ACE0E3"))
      (zenburn-blue+1 ,(hex->color "#94BFF3"))
      (zenburn-blue ,(hex->color "#8CD0D3"))
      (zenburn-blue-1 ,(hex->color "#7CB8BB"))
      (zenburn-blue-2 ,(hex->color "#6CA0A3"))
      (zenburn-blue-3 ,(hex->color "#5C888B"))
      (zenburn-blue-4 ,(hex->color "#4C7073"))
      (zenburn-blue-5 ,(hex->color "#366060"))
      (zenburn-magenta ,(hex->color "#DC8CC3")))))

(defmacro with-zenburn-colors (&body body)
  `(let ,+zenburn-colors+
     (declare (ignorable ,@(mapcar 'car +zenburn-colors+)))
     ,@body))

(with-zenburn-colors
  (define-color-theme "zenburn" ()
    :foreground zenburn-fg
    :background zenburn-bg
    :region `(:foreground ,zenburn-fg+1
              :background ,zenburn-bg+1)
    :show-point-face `(:background ,zenburn-bg+2)
    :interactive-input-face `(:foreground ,zenburn-red)
    :highlight '(:bold-p t)
    :non-focus-complete-face `(:background :tweak_background)
    :font-lock-function-name-face `(:foreground ,zenburn-blue)
    :font-lock-comment-face `(:foreground ,zenburn-fg-1)
    :font-lock-type-face `(:foreground ,zenburn-green)
    :font-lock-variable-name-face `(:foreground ,zenburn-yellow)
    :font-lock-string-face `(:foreground ,zenburn-orange)
    :font-lock-keyword-face `(:foreground ,zenburn-cyan)
    :font-lock-builtin-face `(:foreground ,zenburn-blue+1)
    :compiler-note-highlight `(:foreground ,zenburn-fg+1)
    :compiler-warning-highlight `(:foreground ,zenburn-orange)
    :compiler-error-highlight `(:foreground ,zenburn-red+1)))

(defun zenburn-paren-colors ()
  (with-zenburn-colors
    (capi:set-editor-parenthesis-colors
     (list zenburn-red
           zenburn-green
           zenburn-blue-1
           zenburn-green+1
           zenburn-blue+1
           zenburn-green+2
           zenburn-orange
           zenburn-cyan
           zenburn-magenta
           zenburn-yellow))))

;;; Show presence when loaded
(pushnew :editor-color-theme *features*)