working on prettyprint

TODO.FACTOR.txt

@@ -9,9 +9,7 @@
 - word preview for remote words
 - support USING:
 - special completion for USE:/IN:
-- prettyprint: detect circular structure
 - vectors: ensure its ok with bignum indices
-- parsing words don't print readably
 - if gadgets are moved, added or deleted, update hand.
 - keyboard focus
 - keyboard gestures
@@ -32,7 +30,7 @@
 - ffi unicode strings: null char security hole
 - utf16 string boxing
 - slot compile problem
-- nulls at the end of utf16 strings
+- sdl console crash
 - x86 register decl
 
 + compiler/ffi:

library/lists.factor

@@ -17,10 +17,14 @@ IN: lists USING: generic kernel math ;
 : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
     over [ >r uncons r> append cons ] [ nip ] ifte ;
 
-: contains? ( element list -- ? )
-    #! Test if a list contains an element.
+: contains? ( obj list -- ? )
+    #! Test if a list contains an element equal to an object.
     [ = ] some-with? >boolean ;
 
+: memq? ( obj list -- ? )
+    #! Test if a list contains an object.
+    [ eq? ] some-with? >boolean ;
+
 : partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
     rot [ swapd cons ] [ >r cons r> ] ifte ;
 

library/syntax/prettyprint.factor

@@ -7,42 +7,18 @@ IN: prettyprint
 ! to the generic vocabulary.
 USING: errors generic kernel kernel-internals lists math
 namespaces stdio strings presentation unparser vectors words
-hashtables ;
+hashtables parser ;
 
 SYMBOL: prettyprint-limit
 SYMBOL: one-line
 SYMBOL: tab-size
+SYMBOL: recursion-check
 
 GENERIC: prettyprint* ( indent obj -- indent )
 
 M: object prettyprint* ( indent obj -- indent )
     unparse write ;
 
-: indent ( indent -- )
-    #! Print the given number of spaces.
-    " " fill write ;
-
-: prettyprint-newline ( indent -- )
-    "\n" write indent ;
-
-: prettyprint-element ( indent obj -- indent )
-    over prettyprint-limit get >= [
-        unparse write
-    ] [
-        prettyprint*
-    ] ifte " " write ;
-
-: <prettyprint ( indent -- indent )
-    tab-size get + one-line get [
-        " " write
-    ] [
-        dup prettyprint-newline
-    ] ifte ;
-
-: prettyprint> ( indent -- indent )
-    tab-size get - one-line get
-    [ dup prettyprint-newline ] unless ;
-
 : word-link ( word -- link )
     [
         dup word-name unparse ,
@@ -69,45 +45,98 @@ M: object prettyprint* ( indent obj -- indent )
         drop [ ]
     ] ifte ;
 
-M: word prettyprint* ( indent word -- indent )
+: prettyprint-word ( word -- )
     dup word-name
     swap dup word-attrs swap word-style append
     write-attr ;
 
+M: word prettyprint* ( indent word -- indent )
+    dup parsing? [
+        \ POSTPONE: prettyprint-word " " write
+    ] when
+    prettyprint-word ;
+
+: indent ( indent -- )
+    #! Print the given number of spaces.
+    " " fill write ;
+
+: prettyprint-newline ( indent -- )
+    "\n" write indent ;
+
+: prettyprint-elements ( indent list -- indent )
+    [ prettyprint* " " write ] each ;
+
+: <prettyprint ( indent -- indent )
+    tab-size get + one-line get [
+        " " write
+    ] [
+        dup prettyprint-newline
+    ] ifte ;
+
+: prettyprint> ( indent -- indent )
+    tab-size get - one-line get
+    [ dup prettyprint-newline ] unless ;
+
+: prettyprint-limit? ( indent -- ? )
+    prettyprint-limit get dup [ >= ] [ nip ] ifte ;
+
+: check-recursion ( indent obj quot -- ? indent )
+    #! We detect circular structure.
+    pick prettyprint-limit? >r
+    over recursion-check get memq? r> or [
+        2drop "..." write
+    ] [
+        over recursion-check [ cons ] change
+        call
+        recursion-check [ cdr ] change
+    ] ifte ;
+
 : prettyprint-sequence ( indent start list end -- indent )
     #! Prettyprint a list, with start/end delimiters; eg, [ ],
     #! or { }, or << >>. The body of the list is indented,
     #! unless the list is empty.
     over [
         >r
-        >r prettyprint* <prettyprint
-        r> [ prettyprint-element ] each
-        prettyprint> r> prettyprint*
+        >r prettyprint-word <prettyprint
+        r> prettyprint-elements
+        prettyprint> r> prettyprint-word
     ] [
-        >r >r prettyprint* " " write r> drop r> prettyprint*
+        >r >r prettyprint-word " " write
+        r> drop
+        r> prettyprint-word
     ] ifte ;
 
 M: list prettyprint* ( indent list -- indent )
-    \ [ swap \ ] prettyprint-sequence ;
+    [
+        \ [ swap \ ] prettyprint-sequence
+    ] check-recursion ;
 
 M: cons prettyprint* ( indent cons -- indent )
     #! Here we turn the cons into a list of two elements.
-    \ [[ swap uncons 2list \ ]] prettyprint-sequence ;
+    [
+        \ [[ swap uncons 2list \ ]] prettyprint-sequence
+    ] check-recursion ;
 
 M: vector prettyprint* ( indent vector -- indent )
-    \ { swap vector>list \ } prettyprint-sequence ;
+    [
+        \ { swap vector>list \ } prettyprint-sequence
+    ] check-recursion ;
 
 M: hashtable prettyprint* ( indent hashtable -- indent )
-    \ {{ swap hash>alist \ }} prettyprint-sequence ;
+    [
+        \ {{ swap hash>alist \ }} prettyprint-sequence
+    ] check-recursion ;
 
 M: tuple prettyprint* ( indent tuple -- indent )
-    \ << swap tuple>list \ >> prettyprint-sequence ;
-
-: prettyprint-1 ( obj -- )
-    0 swap prettyprint* drop ;
+    [
+        \ << swap tuple>list \ >> prettyprint-sequence
+    ] check-recursion ;
 
 : prettyprint ( obj -- )
-    prettyprint-1 terpri ;
+    [
+        recursion-check off
+        0 swap prettyprint* drop terpri
+    ] with-scope ;
 
 : vocab-link ( vocab -- link )
     "vocabularies'" swap cat2 ;
@@ -137,4 +166,4 @@ M: tuple prettyprint* ( indent tuple -- indent )
 : .o >oct print ;
 : .h >hex print ;
 
-global [ 40 prettyprint-limit set  4 tab-size set ] bind
+global [ 4 tab-size set ] bind

library/syntax/see.factor

@@ -21,20 +21,20 @@ presentation unparser words ;
     dup vocab-attrs write-attr ;
 
 : prettyprint-IN: ( word -- )
-    \ IN: prettyprint* " " write
+    \ IN: prettyprint-word " " write
     word-vocabulary prettyprint-vocab " " write ;
 
 : prettyprint-: ( indent -- indent )
-    \ : prettyprint* " " write
+    \ : prettyprint-word " " write
     tab-size get + ;
 
 : prettyprint-; ( indent -- indent )
-    \ ; prettyprint*
+    \ ; prettyprint-word
     tab-size get - ;
 
 : prettyprint-prop ( word prop -- )
     tuck word-name word-property [
-        " " write prettyprint-1
+        " " write prettyprint-word
     ] [
         drop
     ] ifte ;
@@ -83,45 +83,46 @@ presentation unparser words ;
     ] keep documentation. ;
 
 : prettyprint-M: ( indent -- indent )
-    \ M: prettyprint-1 " " write tab-size get + ;
+    \ M: prettyprint-word " " write tab-size get + ;
 
 GENERIC: see ( word -- )
 
 M: compound see ( word -- )
     dup prettyprint-IN:
     0 prettyprint-: swap
-    [ prettyprint-1 ] keep
+    [ prettyprint-word ] keep
     [ prettyprint-docs ] keep
     [
-        word-parameter [ prettyprint-element ] each
+        word-parameter prettyprint-elements
         prettyprint-;
     ] keep
     prettyprint-plist prettyprint-newline ;
 
 : see-method ( indent word class method -- indent )
     >r >r >r prettyprint-M:
-    r> r> prettyprint-1 " " write
-    prettyprint-1 " " write
+    r> r> prettyprint-word " " write
+    prettyprint-word " " write
     dup prettyprint-newline
-    r> [ prettyprint-element ] each
+    r> prettyprint-elements
     prettyprint-;
     terpri ;
 
 M: generic see ( word -- )
     dup prettyprint-IN:
     0 swap
-    dup "definer" word-property prettyprint-1 " " write
-    dup prettyprint-1 terpri
+    dup "definer" word-property prettyprint-word " " write
+    dup prettyprint-word terpri
     dup methods [ over >r uncons see-method r> ] each 2drop ;
 
 M: primitive see ( word -- )
     dup prettyprint-IN:
-    "PRIMITIVE: " write dup prettyprint-1 stack-effect. terpri ;
+    "PRIMITIVE: " write dup prettyprint-word stack-effect.
+    terpri ;
 
 M: symbol see ( word -- )
     dup prettyprint-IN:
-    \ SYMBOL: prettyprint-1 " " write . ;
+    \ SYMBOL: prettyprint-word " " write . ;
 
 M: undefined see ( word -- )
     dup prettyprint-IN:
-    \ DEFER: prettyprint-1 " " write . ;
+    \ DEFER: prettyprint-word " " write . ;

library/tools/debugger.factor

@@ -145,9 +145,9 @@ M: object error. ( error -- )
 : :get ( var -- value ) "error-namestack" get (get) ;
 
 : debug-help ( -- )
-    [ :s :r :n :c ] [ prettyprint-1 " " write ] each
+    [ :s :r :n :c ] [ prettyprint-word " " write ] each
     "show stacks at time of error." print
-    \ :get prettyprint-1
+    \ :get prettyprint-word
     " ( var -- value ) inspects the error namestack." print ;
 
 : flush-error-handler ( error -- )

library/tools/interpreter.factor

@@ -201,15 +201,15 @@ SYMBOL: meta-cf
 
 : walk-banner ( -- )
     "The following words control the single-stepper:" print
-    [ &s &r &n &c ] [ prettyprint-1 " " write ] each
+    [ &s &r &n &c ] [ prettyprint-word " " write ] each
     "show stepper stacks." print
-    \ &get prettyprint-1
+    \ &get prettyprint-word
     " ( var -- value ) inspects the stepper namestack." print
-    \ step prettyprint-1 " -- single step over" print
-    \ into prettyprint-1 " -- single step into" print
-    \ (trace) prettyprint-1 " -- trace until end" print
-    \ (run) prettyprint-1 " -- run until end" print
-    \ exit prettyprint-1 " -- exit single-stepper" print ;
+    \ step prettyprint-word " -- single step over" print
+    \ into prettyprint-word " -- single step into" print
+    \ (trace) prettyprint-word " -- trace until end" print
+    \ (run) prettyprint-word " -- run until end" print
+    \ exit prettyprint-word " -- exit single-stepper" print ;
 
 : walk ( quot -- )
     #! Single-step through execution of a quotation.