New callstack display

core/prettyprint/backend/backend.factor

@@ -22,11 +22,13 @@ GENERIC: pprint* ( obj -- )
 
 ! Atoms
 : word-style ( word -- style )
-    [
+    dup "word-style" word-prop >hashtable [
-        dup presented set
+        [
-        dup parsing? over delimiter? rot t eq? or or
+            dup presented set
-        [ bold font-style set ] when
+            dup parsing? over delimiter? rot t eq? or or
-    ] H{ } make-assoc ;
+            [ bold font-style set ] when
+        ] bind
+    ] keep ;
 
 : word-name* ( word -- str )
     word-name "( no name )" or ;
@@ -129,15 +131,9 @@ M: pathname pprint* dup pathname-string "P\" " pprint-string ;
         dup zero? [ 2drop f ] [ >r head r> ] if
     ] when ;
 
-: pprint-hilite ( n object -- )
-    pprint* hilite-index get = [ hilite ] when ;
-
 : pprint-elements ( seq -- )
-    do-length-limit >r dup hilite-quotation get eq? [
+    do-length-limit >r
-        [ length ] keep [ pprint-hilite ] 2each
+    [ pprint* ] each
-    ] [
-        [ pprint* ] each
-    ] if
     r> [ "~" swap number>string " more~" 3append text ] when* ;
 
 GENERIC: pprint-delims ( obj -- start end )

core/prettyprint/prettyprint.factor

@@ -6,7 +6,8 @@ math namespaces sequences strings io.styles io.streams.string
 vectors words prettyprint.backend prettyprint.sections
 prettyprint.config sorting splitting math.parser vocabs
 definitions effects tuples io.files classes continuations
-hashtables classes.mixin classes.union classes.predicate ;
+hashtables classes.mixin classes.union classes.predicate
+combinators quotations ;
 
 : make-pprint ( obj quot -- block in use )
     [
@@ -85,20 +86,48 @@ hashtables classes.mixin classes.union classes.predicate ;
 : .s ( -- ) datastack stack. ;
 : .r ( -- ) retainstack stack. ;
 
-: callframe. ( seq pos -- )
+SYMBOL: ->
+
+\ ->
+{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
+"word-style" set-word-prop
+
+<PRIVATE
+
+! This code is ugly and could probably be simplified
+: remove-step-into
+    building get dup empty? [
+        drop \ (step-into) ,
+    ] [
+        pop dup wrapper? [ wrapped ] when ,
+    ] if ;
+
+: (remove-breakpoints) ( quot -- newquot )
     [
         [
-            hilite-index set
+            {
-            dup hilite-quotation set
+                { break [ ] }
-            2 nesting-limit set
+                { (step-into) [ remove-step-into ] }
-            .
+                [ , ]
-        ] with-scope
+            } case
+        ] each
+    ] [ ] make ;
+
+: remove-breakpoints ( quot pos -- quot' )
+    over quotation? [
+        1+ swap cut [ (remove-breakpoints) ] 2apply
+        [ -> ] swap 3append
     ] [
-        .
+        drop
-    ] if* ;
+    ] if ;
+
+PRIVATE>
 
 : callstack. ( callstack -- )
-    callstack>array 2 <groups> [ callframe. ] assoc-each ;
+    callstack>array 2 <groups> [
+        remove-breakpoints
+        2 nesting-limit [ . ] with-variable
+    ] assoc-each ;
 
 : .c ( -- ) callstack callstack. ;
 

core/prettyprint/sections/sections-docs.factor

@@ -74,7 +74,6 @@ HELP: section
     { $link block }
     { $link inset }
     { $link flow }
-    { $link hilite }
     { $link colon }
 }
 "Instances of this class have the following slots:"

core/prettyprint/sections/sections.factor

@@ -157,11 +157,6 @@ TUPLE: block sections ;
         { highlight t }
     } ;
 
-: hilite ( -- )
-    last-section
-    dup section-style hilite-style union
-    swap set-section-style ;
-
 : start-group ( -- )
     t last-section set-section-start-group? ;