Prettyprinte now highlights elements properly

TODO.FACTOR.txt

@@ -14,6 +14,7 @@
   - history doesn't work in a good way if you ^K the input
   - history: move caret to end
 - finish gui stepper
+  - <input> handled by walker itself
 - graphical module manager tool
 - services do not launch if factor not running
 - integrated error documentation
@@ -21,7 +22,6 @@
 - 'show' doesn't work if invoked from a listener on an object which is
   itself inspected in the listener
 - fix top level window positioning
-- prettyprinter's highlighting of non-leaves doesn't really work
 - nasty inference regressions
 - [ [ dup call ] dup call ] infer hangs
 - the invalid recursion form case needs to be fixed, for inlines too

library/io/stdio.factor

@@ -27,7 +27,8 @@ SYMBOL: stdio
     swap stdio get with-stream-table ;
 
 : with-style ( style quot -- )
-    swap stdio get with-stream-style ;
+    swap dup hash-empty?
+    [ drop call ] [ stdio get with-stream-style ] if ;
 
 : print ( string -- ) stdio get stream-print ;
 

library/syntax/prettyprint.factor

@@ -38,12 +38,13 @@ global [
 
 GENERIC: pprint-section*
 
-TUPLE: section start end nl-after? indent ;
+TUPLE: section start end nl-after? indent style ;
 
-C: section ( length -- section )
+C: section ( style length -- section )
     >r position [ dup rot + dup ] change r>
     [ set-section-end ] keep
     [ set-section-start ] keep
+    [ set-section-style ] keep
     0 over set-section-indent ;
 
 : line-limit? ( -- ? )
@@ -61,20 +62,19 @@ C: section ( length -- section )
         terpri do-indent
     ] if ;
 
-TUPLE: text string style ;
+TUPLE: text string ;
 
 C: text ( string style -- section )
-    pick length 1+ <section> over set-delegate
+    [ >r over length 1+ <section> r> set-delegate ] keep
-    [ set-text-style ] keep
     [ set-text-string ] keep ;
 
 M: text pprint-section*
-    dup text-string swap text-style format ;
+    dup text-string swap section-style format ;
 
 TUPLE: block sections ;
 
-C: block ( -- block )
+C: block ( style -- block )
-    0 <section> over set-delegate
+    [ >r 0 <section> r> set-delegate ] keep
     V{ } clone over set-block-sections
     t over set-section-nl-after?
     tab-size get over set-section-indent ;
@@ -115,12 +115,12 @@ C: block ( -- block )
     ] if ;
 
 : pprint-section ( section -- )
-    dup section-fits?
+    dup section-fits? [ pprint-section* ] [ inset-section ] if ;
-    [ pprint-section* ] [ inset-section ] if ;
 
 TUPLE: newline ;
 
-C: newline ( -- section ) 0 <section> over set-delegate ;
+C: newline ( -- section )
+    H{ } 0 <section> over set-delegate ;
 
 M: newline pprint-section* ( newline -- )
     section-start fresh-line ;
@@ -134,12 +134,18 @@ M: newline pprint-section* ( newline -- )
         section-start last-newline get = [ bl ] unless
     ] if ;
 
+: <style section-style stdio [ <nested-style-stream> ] change ;
+
+: style> stdio [ delegate ] change ;
+
 M: block pprint-section* ( block -- )
+    dup <style
     f swap block-sections [
         over [ dup advance ] when pprint-section drop t
-    ] each drop ;
+    ] each drop
+    style> ;
 
-: <block ( -- ) <block> pprinter-stack get push ;
+: <block ( style -- ) <block> pprinter-stack get push ;
 
 : end-block ( block -- ) position get swap set-section-end ;
 
@@ -162,10 +168,6 @@ GENERIC: pprint* ( obj -- )
 
 : word-style ( word -- style )
     [
-        hilite-next? get [
-            { 0.9 0.9 0.9 1 } background set
-            highlight on
-        ] when
         dup presented set
         parsing? [ bold font-style set ] when
     ] make-hash ;
@@ -218,7 +220,7 @@ M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
 M: word pprint* ( word -- )
     dup "pprint-close" word-prop [ block> ] when
     dup pprint-word
-    "pprint-open" word-prop [ <block ] when ;
+    "pprint-open" word-prop [ H{ } <block ] when ;
 
 M: f pprint* drop \ f pprint-word ;
 
@@ -249,9 +251,14 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
     dup parsing? [ \ POSTPONE: pprint-word ] when pprint* ;
 
 : pprint-hilite ( object n -- )
-    hilite-index get = hilite-next? set
+    hilite-index get = [
-    pprint-element
+        H{
-    hilite-next? off ;
+            { background { 0.9 0.9 0.9 1 } }
+            { highlight t }
+        } <block pprint-element block>
+    ] [
+        pprint-element
+    ] if ;
 
 : pprint-elements ( seq -- )
     length-limit? >r dup hilite-quotation get eq? [
@@ -282,7 +289,7 @@ M: tuple pprint* ( tuple -- )
     [
         \ T{ pprint*
         tuple>array dup first pprint*
-        <block 1 tail-slice pprint-elements
+        H{ } <block 1 tail-slice pprint-elements
         \ } pprint*
     ] check-recursion ;
 
@@ -303,7 +310,7 @@ M: wrapper pprint* ( wrapper -- )
 : with-pprint ( quot -- )
     [
         V{ } clone recursion-check set
-        <block> f ?push pprinter-stack set
+        H{ } <block> f ?push pprinter-stack set
         call end-blocks do-pprint
     ] with-scope ; inline
 

library/syntax/see.factor

@@ -19,7 +19,7 @@ sequences strings styles words ;
 
 : in. ( word -- )
     word-vocabulary [
-        <block \ IN: pprint-word write-vocab block;
+        H{ } <block \ IN: pprint-word write-vocab block;
     ] when* ;
 
 : (synopsis) ( word -- )
@@ -64,7 +64,9 @@ M: word (see) drop ;
 : pprint-; \ ; pprint-word ;
 
 : see-body ( quot word -- )
-    <block swap pprint-elements pprint-; declarations. block; ;
+    H{ } <block
+    swap pprint-elements pprint-; declarations.
+    block; ;
 
 M: compound (see)
     dup word-def swap see-body ;
@@ -72,7 +74,7 @@ M: compound (see)
 : method. ( word class method -- )
     \ M: pprint-word
     >r pprint-word pprint-word r>
-    <block pprint-elements pprint-; block; ;
+    H{ } <block pprint-elements pprint-; block; ;
 
 M: generic (see)
     dup dup "combination" word-prop swap see-body
@@ -102,7 +104,7 @@ M: predicate class.
     \ PREDICATE: pprint-word
     dup superclass pprint-word
     dup pprint-word
-    <block
+    H{ } <block
     "definition" word-prop pprint-elements
     pprint-; block; ;