Auto-use now prints out USING: forms again

basis/prettyprint/sections/sections-docs.factor

@@ -1,6 +1,6 @@
 USING: prettyprint io kernel help.markup help.syntax
 prettyprint.config words hashtables math
-strings definitions ;
+strings definitions quotations ;
 IN: prettyprint.sections
 
 HELP: position
@@ -13,7 +13,6 @@ HELP: line-limit?
 { $values { "?" "a boolean" } }
 { $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ;
 
-
 HELP: do-indent
 { $description "Outputs the current indent nesting to " { $link output-stream } "." } ;
 
@@ -211,3 +210,7 @@ $prettyprinting-note ;
 HELP: do-pprint
 { $values { "block" block } }
 { $description "Recursively output all children of the given block. The continuation is restored and output terminates if the line length is exceeded; this test is performed in " { $link fresh-line } "." } ;
+
+HELP: with-pprint
+{ $values { "obj" object } { "quot" quotation } }
+{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ;

basis/prettyprint/sections/sections.factor

@@ -326,3 +326,19 @@ M: block long-section ( block -- )
             ] each
         ] each
     ] if-nonempty ;
+
+: make-pprint ( obj quot -- block in use )
+    [
+        0 position set
+        H{ } clone pprinter-use set
+        V{ } clone recursion-check set
+        V{ } clone pprinter-stack set
+        over <object
+        call
+        pprinter-block
+        pprinter-in get
+        pprinter-use get keys
+    ] with-scope ; inline
+
+: with-pprint ( obj quot -- )
+    make-pprint 2drop do-pprint ; inline

basis/vocabs/prettyprint/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/vocabs/prettyprint/prettyprint-tests.factor

@@ -0,0 +1,47 @@
+IN: vocabs.prettyprint.tests
+USING: vocabs.prettyprint tools.test io.streams.string multiline eval ;
+
+: manifest-test-1 ( -- string )
+    <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+
+    << manifest get pprint-manifest >> "> ;
+
+[
+<" USING: kernel namespaces syntax vocabs.parser
+vocabs.prettyprint ;">
+]
+[ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test
+
+: manifest-test-2 ( -- string )
+    <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+    IN: vocabs.prettyprint.tests
+
+    << manifest get pprint-manifest >> "> ;
+
+[
+<" USING: kernel namespaces syntax vocabs.parser
+vocabs.prettyprint ;
+IN: vocabs.prettyprint.tests">
+]
+[ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test
+
+: manifest-test-3 ( -- string )
+    <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+    FROM: math => + - ;
+    QUALIFIED: system
+    QUALIFIED-WITH: assocs a
+    EXCLUDE: parser => run-file ;
+    IN: vocabs.prettyprint.tests
+
+    << manifest get pprint-manifest >> "> ;
+
+[
+<" USING: kernel namespaces syntax vocabs.parser
+vocabs.prettyprint ;
+FROM: math => + - ;
+QUALIFIED: system
+QUALIFIED-WITH: assocs a
+EXCLUDE: parser => run-file ;
+IN: vocabs.prettyprint.tests">
+]
+[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test

basis/vocabs/prettyprint/prettyprint.factor

@@ -0,0 +1,86 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sorting sequences vocabs io io.styles arrays assocs
+namespaces sets parser colors prettyprint.backend prettyprint.sections
+vocabs.parser make fry math.order ;
+IN: vocabs.prettyprint
+
+: pprint-vocab ( vocab -- )
+    [ vocab-name ] [ vocab ] bi present-text ;
+
+: pprint-in ( vocab -- )
+    [ \ IN: pprint-word pprint-vocab ] with-pprint ;
+
+<PRIVATE
+
+: sort-vocabs ( seq -- seq' )
+    [ [ vocab-name ] compare ] sort ;
+
+: pprint-using ( seq -- )
+    [ "syntax" vocab = not ] filter
+    sort-vocabs [
+        \ USING: pprint-word
+        [ pprint-vocab ] each
+        \ ; pprint-word
+    ] with-pprint ;
+
+GENERIC: pprint-qualified ( qualified -- )
+
+M: qualified pprint-qualified ( qualified -- )
+    [
+        dup [ vocab>> vocab-name ] [ prefix>> ] bi = [
+            \ QUALIFIED: pprint-word
+            vocab>> pprint-vocab
+        ] [
+            \ QUALIFIED-WITH: pprint-word
+            [ vocab>> pprint-vocab ] [ prefix>> text ] bi
+        ] if
+    ] with-pprint ;
+
+M: from pprint-qualified ( from -- )
+    [
+        \ FROM: pprint-word
+        [ vocab>> pprint-vocab "=>" text ]
+        [ names>> [ text ] each ] bi
+        \ ; pprint-word
+    ] with-pprint ;
+
+M: exclude pprint-qualified ( exclude -- )
+    [
+        \ EXCLUDE: pprint-word
+        [ vocab>> pprint-vocab "=>" text ]
+        [ names>> [ text ] each ] bi
+        \ ; pprint-word
+    ] with-pprint ;
+
+M: rename pprint-qualified ( rename -- )
+    [
+        \ RENAME: pprint-word
+        [ word>> text ]
+        [ vocab>> text "=>" text ]
+        [ words>> >alist first first text ]
+        tri
+    ] with-pprint ;
+
+PRIVATE>
+
+: pprint-manifest ( manifest -- )
+    [
+        [ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
+        [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
+        [ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
+        tri
+    ] { } make
+    [ nl ] [ call( -- ) ] interleave ;
+
+[
+    nl
+    { { font-style bold } { font-name "sans-serif" } } [
+        "Restarts were invoked adding vocabularies to the search path." print
+        "To avoid doing this in the future, add the following USING:" print
+        "and IN: forms at the top of the source file:" print nl
+    ] with-style
+    { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } }
+    [ manifest get pprint-manifest ] with-nesting
+    nl nl
+] print-use-hook set-global

core/vocabs/parser/parser.factor

@@ -26,6 +26,10 @@ M: manifest clone
         [ clone ] change-qualified-vocabs
         [ clone ] change-extra-words ;
 
+TUPLE: extra-words words ;
+
+C: <extra-words> extra-words
+
 <PRIVATE
 
 : clear-manifest ( -- )
@@ -49,10 +53,6 @@ M: manifest clone
 : (lookup) ( name assoc -- word/f )
     at dup forward-reference? [ drop f ] when ;
 
-TUPLE: extra-words words ;
-
-C: <extra-words> extra-words
-
 : (use-words) ( assoc -- extra-words seq )
     <extra-words> manifest get qualified-vocabs>> ;