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

@@ -1,46 +1,47 @@
-! Copyright (C) 2003, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: io
-USING: errors generic hashtables kernel namespaces sequences
-strings styles ;
-
-! Default stream
-SYMBOL: stdio
-
-: close ( -- ) stdio get stream-close ;
-
-: readln ( -- string/f ) stdio get stream-readln ;
-: read1 ( -- char/f ) stdio get stream-read1 ;
-: read ( count -- string ) stdio get stream-read ;
-
-: write1 ( char -- ) stdio get stream-write1 ;
-: write ( string -- ) stdio get stream-write ;
-: flush ( -- ) stdio get stream-flush ;
-
-: terpri ( -- ) stdio get stream-terpri ;
-: format ( string style -- ) stdio get stream-format ;
-
-: with-nesting ( style quot -- )
-    swap stdio get with-nested-stream ;
-
-: tabular-output ( grid style quot -- )
-    swap stdio get with-stream-table ;
-
-: with-style ( style quot -- )
-    swap stdio get with-stream-style ;
-
-: print ( string -- ) stdio get stream-print ;
-
-: with-stream* ( stream quot -- )
-    [ swap stdio set call ] with-scope ; inline
-
-: with-stream ( stream quot -- )
-    swap [ [ close ] cleanup ] with-stream* ; inline
-
-: bl ( -- ) " " write ;
-
-: write-object ( string object -- )
-    presented associate format ;
-
-: write-outliner ( string object content -- )
-    outline associate [ write-object ] with-nesting ;
+! Copyright (C) 2003, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: io
+USING: errors generic hashtables kernel namespaces sequences
+strings styles ;
+
+! Default stream
+SYMBOL: stdio
+
+: close ( -- ) stdio get stream-close ;
+
+: readln ( -- string/f ) stdio get stream-readln ;
+: read1 ( -- char/f ) stdio get stream-read1 ;
+: read ( count -- string ) stdio get stream-read ;
+
+: write1 ( char -- ) stdio get stream-write1 ;
+: write ( string -- ) stdio get stream-write ;
+: flush ( -- ) stdio get stream-flush ;
+
+: terpri ( -- ) stdio get stream-terpri ;
+: format ( string style -- ) stdio get stream-format ;
+
+: with-nesting ( style quot -- )
+    swap stdio get with-nested-stream ;
+
+: tabular-output ( grid style quot -- )
+    swap stdio get with-stream-table ;
+
+: with-style ( style quot -- )
+    swap dup hash-empty?
+    [ drop call ] [ stdio get with-stream-style ] if ;
+
+: print ( string -- ) stdio get stream-print ;
+
+: with-stream* ( stream quot -- )
+    [ swap stdio set call ] with-scope ; inline
+
+: with-stream ( stream quot -- )
+    swap [ [ close ] cleanup ] with-stream* ; inline
+
+: bl ( -- ) " " write ;
+
+: write-object ( string object -- )
+    presented associate format ;
+
+: write-outliner ( string object content -- )
+    outline associate [ write-object ] with-nesting ;

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
-    [ set-text-style ] keep
+    [ >r over length 1+ <section> r> set-delegate ] 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 )
-    0 <section> over set-delegate
+C: block ( style -- block )
+    [ >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?
-    [ pprint-section* ] [ inset-section ] if ;
+    dup section-fits? [ 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
-    pprint-element
-    hilite-next? off ;
+    hilite-index get = [
+        H{
+            { 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; ;
 

library/tools/interpreter.factor

@@ -6,7 +6,7 @@ namespaces prettyprint sequences strings vectors words ;
 
 ! A Factor interpreter written in Factor. It can transfer the
 ! continuation to and from the primary interpreter. Used by
-! compiler for partial evaluation, also by the walker. 
+! compiler for partial evaluation, also by the walker.
 
 ! Meta-stacks;
 SYMBOL: meta-d