;;;; Copyright (C) 2013 Paulo Madeira
 ;;;;
 ;;;; This Source Code Form is subject to the terms of the Mozilla Public
 ;;;; License, v. 2.0. If a copy of the MPL was not distributed with this
 ;;;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
 
 ;;; Interface
 
 (cl:in-package #:cl-user)
 

 (defpackage #:editor-color-theme
   (:use #:cl)

   (:export #:*current-colors*

            #:all-color-themes
            #:color-theme-args
            #:color-theme
            #:define-color-theme
            #:remove-color-theme
            ))

 
 (in-package #:editor-color-theme)
 
 
 ;;; Configuration
 

 ;; Default foreground and background colors
 (defconstant +default-foreground-color+ :black)
 (defconstant +default-background-color+ :white)

 (defvar *current-colors* (make-hash-table))

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

 (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
     :incremental-search-face
     :incremental-search-other-matches-face
     ))
 
 
 

 (defclass editor-panes-theme ()
   ((editor-panes :initform nil :accessor editor-panes)

    (buffers-panes :initform nil :accessor buffers-panes)

    (editor-background :initform +default-background-color+ :accessor bg)

    (editor-foreground :initform +default-foreground-color+ :accessor fg)

    (buffers-background :initform +default-background-color+ :accessor buffers-bg)
    (buffers-foreground :initform +default-foreground-color+ :accessor buffers-fg)
    (buffers-selected-foreground :initform +default-foreground-color+ :accessor buffers-selected-fg)))

 
 (defclass listener-panes-theme ()

   ((listener-panes :initform nil :accessor listener-panes)
    (listener-foreground :initform +default-foreground-color+ :accessor bg)
    (listener-background :initform +default-background-color+ :accessor fg)))

 
 
 (defclass general-panes-theme ()

   ((output-panes :initform nil :accessor output-panes)
    (output-foreground :initform +default-foreground-color+ :accessor output-fg)
    (output-background :initform +default-background-color+ :accessor output-bg)))

 
 (defvar *editor-tool* (make-instance 'editor-panes-theme))
 (defvar *listener-tool* (make-instance 'listener-panes-theme))
 (defvar *all-tools* (make-instance 'general-panes-theme))

 (defun all-color-themes ()
   (maphash #'(lambda (key value)

                (declare (ignore value))
                key)
            *all-color-themes*))

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

   (multiple-value-bind (data found?)

       (gethash theme-name *all-color-themes*)
     (if found?

         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)))
 

 
 (defun buffers-color-function (lp symbol state)
   (declare (ignore lp))
   (cond ((eq state :normal)
          (buffers-fg *editor-tool*))
         ((eq state :selected)
          (buffers-selected-fg *editor-tool*))))

 (defun update-pane-colors (pane foreground background)

   (setf (capi:simple-pane-foreground pane) foreground)
   (setf (capi:simple-pane-background pane) background)

 
   (when (and (typep pane 'capi:editor-pane)
              (editor::buffer-font-lock-mode-p (capi:editor-pane-buffer pane)))

     (gp:invalidate-rectangle pane)))

 
 
 (defgeneric clear-colors (tool)
   (:documentation "Clear colors for tool keeping other data untouched"))
 
 (defgeneric update (tool)
   (:documentation "Update tool's colors"))
 
 
 (defmethod clear-colors ((self editor-panes-theme))
   (with-slots (editor-background editor-foreground) self
     (setf editor-background +default-background-color+)
     (setf editor-foreground +default-foreground-color+)))
 
 (defmethod clear-colors ((self listener-panes-theme))
   (with-slots (listener-background listener-foreground) self
     (setf listener-background +default-background-color+)
     (setf listener-foreground +default-foreground-color+)))
 
 (defmethod clear-colors ((self general-panes-theme))
   (with-slots (output-background output-foreground) self
     (setf output-background +default-background-color+)
     (setf output-foreground +default-foreground-color+)))
 
 
 (defmethod update ((self editor-panes-theme))
   (mapcar #'(lambda (pane)
               (update-pane-colors pane (fg self) (bg self)))

           (editor-panes self))
   (mapcar #'(lambda (pane)
               (update-pane-colors pane (buffers-fg self) (buffers-bg self)))
           (buffers-panes self)))

 
 (defmethod update ((self listener-panes-theme))
   (mapcar #'(lambda (pane)
               (update-pane-colors pane (fg self) (bg self)))
           (listener-panes self)))

 (defmethod update ((self general-panes-theme))
   (mapcar #'(lambda (pane)
               (update-pane-colors pane (output-fg self) (output-bg self)))
           (output-panes self)))

 (defun set-color-theme (theme-name)
   (destructuring-bind (&rest color-theme-args

                        &key foreground background
                          listener-foreground
                          listener-background
                          output-foreground
                          output-background
                          buffers-foreground
                          buffers-selected-foreground
                          buffers-background
                        &allow-other-keys)

       (color-theme-args theme-name)

     ;; new instances of tools wrappers
     (clear-colors *editor-tool*)
     (clear-colors *listener-tool*)
     (clear-colors *all-tools*)

     ;; editor foreground and background

     (when foreground
       (setf (fg *editor-tool*) foreground))
     (when background
       (setf (bg *editor-tool*) background))

     ;; listener foreground and background, uses
     ;; the :background and :foreground if not specified

     (setf (fg *listener-tool*)

           (or listener-foreground

               (fg *editor-tool*))
           (bg *listener-tool*)

           (or listener-background

               (bg *editor-tool*)))
 

     ;; output foreground and background, uses :background and
     ;; :foreground if not specified

     (setf (output-fg *all-tools*)

           (or output-foreground

               (fg *editor-tool*))
           (output-bg *all-tools*)

           (or output-background

               (bg *editor-tool*)))

 
     ;; buffers list colors
     (setf (buffers-fg *editor-tool*)
           (or buffers-foreground
               (fg *editor-tool*))

           (buffers-selected-fg *editor-tool*)
           (or buffers-selected-foreground
               (buffers-fg *editor-tool*))

           (buffers-bg *editor-tool*)
           (or buffers-background
               (bg *editor-tool*)))
 

     (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-tool*)
   (update *listener-tool*)
   (update *all-tools*)

   theme-name)
 
 (defun define-color-theme (theme-name super-theme-names

                            &rest color-theme-args &key &allow-other-keys)
   (unless super-theme-names
     (setf super-theme-names '("default")))

   (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*))
 
 (defun set-editor-pane-colors (pane)
   (typecase pane
     (capi:editor-pane
      (progn

        (pushnew pane (editor-panes *editor-tool*))

        (let ((bg-color (bg *editor-tool*))
              (fg-color (fg *editor-tool*)))
          (setf (capi:simple-pane-foreground pane) fg-color)
          (setf (capi:simple-pane-background pane) bg-color))))))

 (defun set-listener-pane-colors (pane)
   (typecase pane
     (capi:editor-pane
      (progn

        (pushnew pane (listener-panes *listener-tool*))

        (let ((bg-color (bg *listener-tool*))
              (fg-color (fg *listener-tool*)))
          (setf (capi:simple-pane-foreground pane) fg-color)
          (setf (capi:simple-pane-background pane) bg-color))))))

 (defun set-collector-pane-colors (pane)

   ;;(when (typep (capi:top-level-interface pane) 'lw-tools:listener)
   (pushnew pane (output-panes *all-tools*))
   (let ((bg-color (output-bg *all-tools*))
         (fg-color (output-fg *all-tools*)))
     (setf (capi:simple-pane-foreground pane) fg-color)
     (setf (capi:simple-pane-background pane) bg-color)))

 
 (defun set-mulitcolumn-list-panel-colors (pane)

   (when (or (eq (capi:capi-object-name pane) 'lw-tools::buffers-list)
             (eq (capi:capi-object-name pane) 'lispworks-tools::narrow-buffers-list))

     (pushnew pane (buffers-panes *editor-tool*))

     (when (eq (capi:capi-object-name pane) 'lispworks-tools::narrow-buffers-list)
       (setf (slot-value pane 'capi::color-function) #'buffers-color-function))

     (update-pane-colors pane (buffers-fg *editor-tool*) (buffers-bg *editor-tool*))))
 

 (lispworks:defadvice ((method capi:interface-display :before (lw-tools:editor))
                       change-editor-colors
                       :before
                       :documentation "Change editor colors.")
     (interface)
   (capi:map-pane-descendant-children interface 'set-editor-pane-colors))
 
 

 ;; we don't have defined capi:interface-display for lw-tools::listener,
 ;; so nothing to advice. Instead we need to define our own
 (sys::without-warning-on-redefinition

     (defmethod capi:interface-display :before ((self lw-tools::listener))
       (capi:map-pane-descendant-children
        self 'set-listener-pane-colors)))

 ;; capi:collector-pane does'nt have interface-display method called,
 ;; so we adding the :after constuctor instead
 (sys::without-warning-on-redefinition
   (defmethod initialize-instance :after ((self capi:collector-pane) &rest
                                          clos::initargs &key &allow-other-keys)
     (set-collector-pane-colors self)))
 

 (lispworks:defadvice ((method initialize-instance :after (capi:multi-column-list-panel))
                       change-multicolumn-colors
                       :after
                       :documentation "Change capi:multi-column-list-panel colors")
     (self &rest initargs &key &allow-other-keys)

   (declare (ignore initargs))

   (set-mulitcolumn-list-panel-colors self))
 
 

 ;; 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)

   (pushnew pane (editor-panes *editor-tool*)))

 
 (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)
   :incremental-search-face '(:background :tweak_background)
   :incremental-search-other-matches-face '(:underline-p t))
 
 (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 '()
   :incremental-search-face '(:background :tweak_background)
   :incremental-search-other-matches-face '(:underline-p t))
 
 
 (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)
   :incremental-search-face '(:background :tweak_background)
   :incremental-search-other-matches-face '(:underline-p t))
 
 
 (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)
   :incremental-search-face '(:background :tweak_background)
   :incremental-search-other-matches-face '(:underline-p t))
 
 

 (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))

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