Break fill newlines when previous section contains a break

s-expressionists · Jul 4, 2023 · 98a82fb · 98a82fb
1 parent f5e389f
commit 98a82fb
Show file tree

Hide file tree

Showing 6 changed files with 22 additions and 12 deletions.
diff --git a/code/pretty-stream.lisp b/code/pretty-stream.lisp
@@ -38,7 +38,11 @@
    (section-end :accessor section-end
                 :initarg :section-end
                 :initform nil
-                :type (or null newline block-end))))
+                :type (or null newline block-end))
+   (simplep :accessor simplep
+            :initarg :simplep
+            :initform nil
+            :type boolean)))
 
 (defclass text (instruction)
   ((value :accessor value
@@ -75,7 +79,10 @@
     (prin1 (width obj) stream)))
 
 (defclass newline (section-start)
-  ())
+  ((break-before-p :accessor break-before-p
+                   :initarg :break-before-P
+                   :initform nil
+                   :type boolean)))
 
 (defclass fresh-newline (newline)
   ())
@@ -248,7 +255,7 @@
                    finally (terpri stream)
                    if (eq sub instruction)
                      do (write-char #\[ stream)
-                        (setf ch #\-)
+                        (setf ch (if (simplep instruction) #\- #\=))
                    else if (eq sub (section-end instruction))
                      do (write-char #\] stream)
                         (setf ch #\Space)
@@ -331,6 +338,10 @@
                 instruction (next instruction)))
          (otherwise
           (cond (last-maybe-break
+                 (unless (or (eq t section)
+                             (simplep section)
+                             (null (section-end section)))
+                   (setf (break-before-p (section-end section)) t))
                  (setf instruction last-maybe-break
                        (fill-pointer (fragments stream)) (fragment-index last-maybe-break)
                        section last-maybe-break
@@ -531,6 +542,8 @@
               (not allow-break-p))
          t)
         ((and (not mode)
+              (or (not (break-before-p instruction))
+                  (not (section-end instruction)))
               (not (miser-p stream instruction)))
          :maybe-break)
         (t
@@ -642,7 +655,12 @@
                                    (eq s parent)
                                    (and (typep s 'newline)
                                         (> (depth s) depth)))
-                           (setf (section-end s) newline)
+                           (setf (section-end s) newline
+                                 (simplep s) (loop for i = (next s) then (next i)
+                                                   finally (return t)
+                                                   while (and i (not (eq i newline)))
+                                                   when (typep i 'newline)
+                                                     return nil))
                            t))
                        sections)
             (section newline) (car (sections stream)))

diff --git a/code/shim/test/expected-failures/abcl.sexp b/code/shim/test/expected-failures/abcl.sexp
@@ -1,2 +1 @@
-PPRINT-NEWLINE.FILL.7
 PPRINT-LOGICAL-BLOCK.17 ; ABCL's circle detection has some limits
diff --git a/code/shim/test/expected-failures/clasp.sexp b/code/shim/test/expected-failures/clasp.sexp
@@ -2,5 +2,3 @@
 :ALLOW-NIL-ARRAYS
 :MAKE-CONDITION-WITH-COMPOUND-NAME
 :NO-FLOATING-POINT-UNDERFLOW-BY-DEFAULT
-
-PPRINT-NEWLINE.FILL.7
diff --git a/code/shim/test/expected-failures/cmucl.sexp b/code/shim/test/expected-failures/cmucl.sexp
@@ -1,3 +1 @@
 :NIL-VECTORS-ARE-STRINGS
-
-PPRINT-NEWLINE.FILL.7
diff --git a/code/shim/test/expected-failures/default.sexp b/code/shim/test/expected-failures/default.sexp
@@ -1 +0,0 @@
-PPRINT-NEWLINE.FILL.7

diff --git a/code/shim/test/expected-failures/ecl.sexp b/code/shim/test/expected-failures/ecl.sexp
@@ -2,5 +2,3 @@
 :ALLOW-NIL-ARRAYS
 :MAKE-CONDITION-WITH-COMPOUND-NAME
 :NO-FLOATING-POINT-UNDERFLOW-BY-DEFAULT
-
-PPRINT-NEWLINE.FILL.7