@@ -28,6 +28,7 @@

                                (:file "utils")

                                (:file "capi-utils")

                                (:file "pprint-setup")

+                               (:file "editor-color-theme")

                                (:file "store")

                                (:file "aws-dispatcher")

                                (:file "aws-utils")

@@ -178,6 +178,7 @@

                                                              'capi:destroy interface))))))

 (defun run (&optional accounts)

+  (cl+ssl:reload)

   (setf *print-readably* nil

         *accounts* (reprocess-accounts (load-accounts accounts))

         aws:*session* (mfa-tool.credential-provider:make-aws-session))

@@ -206,6 +207,7 @@

   (abort))

 (defun main ()

+  (mfa-tool.editor-color-theme:color-theme "zenburn" nil)

   (mfa-tool.credential-provider:setup-default-chain)

   (mfa-tool.pprint-setup:setup-pprint)

   (setf *debugger-hook* 'debugging)

new file mode 100644

@@ -0,0 +1,441 @@

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