Update style interface

code/ansi/ansi.lisp

@@ -70,6 +70,14 @@
 (defun write-ansi (value stream)
   (format stream "~C[~Am" #\Escape value))
 
+(defparameter *styles*
+  (list :number (make-instance 'ansi-style :foreground :yellow)
+        :dynamic-variable (make-instance 'ansi-style :foreground :cyan)
+        :constant-variable (make-instance 'ansi-style :foreground :cyan :font :bold)))
+
+(defmethod (setf inravina:stream-style) :around ((name keyword) (stream ansi-stream))
+  (call-next-method (getf *styles* name) stream))
+
 (defmethod (setf inravina:stream-style) (new-style (stream ansi-stream))
   (let ((foreground (foreground new-style))
         (background (background new-style))
@@ -110,19 +118,5 @@
                   target))
     (setf (style stream) new-style)))
 
-(defmethod inravina:stream-copy-style ((stream ansi-stream) style &rest overrides &key &allow-other-keys)
-  (make-instance 'ansi-style
-                 :foreground (getf overrides :foreground (foreground style))
-                 :background (getf overrides :background (background style))
-                 :font (getf overrides :font (font style))))
-
 (defmethod inravina:stream-style ((stream ansi-stream))
   (style stream))
-
-(defparameter *styles*
-  (list :number (make-instance 'ansi-style :foreground :yellow)
-        :dynamic-variable (make-instance 'ansi-style :foreground :cyan)
-        :constant-variable (make-instance 'ansi-style :foreground :cyan :font :bold)))
-
-(defmethod inravina:get-named-style (client (stream pretty-stream) name)
-  (inravina:stream-copy-style stream (getf *styles* name)))

code/form-printers.lisp

@@ -761,8 +761,8 @@
 
 (defun pprint-symbol (client stream object &rest options &key &allow-other-keys)
   (declare (ignore options))
-  (with-named-style (client stream
-                     (cond ((constant-variable-p object)
+  (with-style (client stream
+               :name (cond ((constant-variable-p object)
                             :constant-variable)
                            ((dynamic-variable-p object)
                             :dynamic-variable)

code/interface.lisp

@@ -182,16 +182,17 @@
     (declare (ignore stream))
     new-style))
 
-(defgeneric stream-copy-style (stream style &rest overrides &key &allow-other-keys)
-  (:method (stream style &rest overrides &key &allow-other-keys)
-    (declare (ignore stream style overrides))
+(defgeneric make-style (client stream &rest initargs &key)
+  (:method (client stream &rest initargs &key)
+    (declare (ignore client stream initargs))
     nil))
 
-(defmacro with-style-overrides ((stream &rest overrides) &body body)
+(defmacro with-style ((client stream &rest initargs) &body body)
   (let ((previous-var (gensym)))
     `(let ((,previous-var (stream-style ,stream)))
-       (setf (stream-style ,stream) (stream-copy-style ,stream ,previous-var ,@overrides))
-       (unwind-protect (progn ,@body)
+       (setf (stream-style ,stream) (make-style ,client ,stream ,@initargs))
+       (unwind-protect
+            (progn ,@body)
          (setf (stream-style ,stream) ,previous-var)))))
 
 (defgeneric stream-scale-column (stream column old-style new-style)
@@ -210,25 +211,6 @@
     (- (or end (length string))
        (or start 0))))
 
-(defgeneric get-named-style (client stream name)
-  (:method (client stream name)
-    (declare (ignore client stream name))
-    nil))
-
-(defmacro with-named-style ((client stream name) &body body)
-  (let ((previous-var (gensym))
-        (new-var (gensym))
-        (body-fun (gensym)))
-    `(let ((,previous-var (stream-style ,stream))
-           (,new-var (get-named-style ,client ,stream ,name))
-           (,body-fun (lambda () ,@body)))
-       (cond (,new-var
-              (setf (stream-style ,stream) ,new-var)
-              (unwind-protect (funcall ,body-fun)
-                (setf (stream-style ,stream) ,previous-var)))
-             (t
-              (funcall ,body-fun))))))
-
 (defmacro define-interface ((client-var client-class &optional intrinsic) &body body)
   (let* ((intrinsic-pkg (if intrinsic (find-package '#:common-lisp) *package*))
          (initial-pprint-dispatch-var (ensure-symbol '#:*initial-pprint-dispatch*))

code/packages.lisp

@@ -20,9 +20,9 @@
            #:define-interface
            #:execute-logical-block
            #:expand-logical-block
-           #:get-named-style
            #:make-dispatch-function
            #:make-pretty-stream
+           #:make-style
            #:pprint-apply
            #:pprint-argument-list
            #:pprint-array
@@ -69,7 +69,6 @@
            #:pretty-stream
            #:pretty-stream-p
            #:set-pprint-dispatch
-           #:stream-copy-style
            #:stream-measure-char
            #:stream-measure-string
            #:stream-scale-column

code/pretty-stream.lisp

@@ -884,17 +884,17 @@
       (stream-style (target stream))))
 
 (defmethod (setf stream-style) (new-style (stream pretty-stream))
-  (if (blocks stream)
-      (push-instruction (make-instance 'style
-                                       :style new-style
-                                       :section (car (sections stream))
-                                       :parent (car (blocks stream)))
-                        stream)
-      (setf (stream-style (target stream)) new-style)))
-
-(defmethod stream-copy-style ((stream pretty-stream) style &rest overrides &key &allow-other-keys)
-  (apply #'stream-copy-style
-         (target stream) (frob-style stream style)  overrides))
+  (when new-style
+    (if (blocks stream)
+        (push-instruction (make-instance 'style
+                                         :style new-style
+                                         :section (car (sections stream))
+                                         :parent (car (blocks stream)))
+                          stream)
+        (setf (stream-style (target stream)) new-style))))
+
+(defmethod make-style (client (stream pretty-stream) &rest initargs &key)
+  (apply #'make-style client (target stream) initargs))
 
 (defmethod stream-scale-column ((stream pretty-stream) column old-style new-style)
   (stream-scale-column (target stream) column