Revised prettyprinter
slava
parent
9a56489bf9
commit
e520478032
|
|
@ -1,9 +1,4 @@
|
|||
- live search: timer delay would be nice
|
||||
- fix this:
|
||||
[ 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 11 11 11 113 ] .
|
||||
[ 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 11 11 11 113
|
||||
]
|
||||
- prettier printing of hashtable literals, alists, cond, ...
|
||||
- menu should stay up if mouse button released
|
||||
- roundoff is still not quite right with tracks
|
||||
- fix compiled gc check
|
||||
|
|
@ -11,6 +6,7 @@
|
|||
- float boxing and overflow checks need a gc check too
|
||||
- [ [ dup call ] dup call ] infer hangs
|
||||
- growable data heap
|
||||
- erg's frange crash
|
||||
|
||||
+ ui:
|
||||
|
||||
|
|
@ -36,6 +32,7 @@
|
|||
|
||||
+ module system:
|
||||
|
||||
- modules should support definition protocol
|
||||
- track a list of assets loaded from each module's file
|
||||
- C types should be words
|
||||
- TYPEDEF: float { ... } { ... } ; ==> \ float T{ c-type ... } "c-type" swp
|
||||
|
|
@ -60,6 +57,7 @@
|
|||
- infer which variables are read, written in a quotation
|
||||
- compiled continuations
|
||||
- compiled call traces
|
||||
- amd64 structs-by-value bug
|
||||
|
||||
+ misc:
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help io prettyprint ;
|
||||
USING: help io prettyprint prettyprint-internals ;
|
||||
|
||||
ARTICLE: "prettyprint" "The prettyprinter"
|
||||
"One of Factor's key features is the ability to print almost any object as a valid source literal expression. This greatly aids debugging and provides the building blocks for light-weight object serialization facilities."
|
||||
|
|
@ -56,8 +56,10 @@ $terpri
|
|||
"Two types of leaf sections:"
|
||||
{ $subsection text }
|
||||
{ $subsection newline }
|
||||
"Nesting and denesting is done using three words. There are two words to denest a block; they vary in indentation policy:"
|
||||
{ $subsection <block }
|
||||
"Nesting and denesting is done using a set words:"
|
||||
{ $subsection <inset }
|
||||
{ $subsection <flow }
|
||||
{ $subsection <narrow }
|
||||
{ $subsection <defblock }
|
||||
{ $subsection block> }
|
||||
{ $subsection block; }
|
||||
"Recall that since " { $link text } " sections take style hashtables as input, any type of formatted text can be output, including presentations. See " { $link "styles" } " to explore the possibility." ;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,4 @@ GENERIC: where* ( defspec -- loc )
|
|||
|
||||
GENERIC: subdefs ( defspec -- seq )
|
||||
|
||||
: see-subdefs ( word -- ) subdefs [ see ] each ;
|
||||
|
||||
GENERIC: forget ( defspec -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: help
|
||||
USING: arrays definitions errors generic graphs hashtables
|
||||
io kernel namespaces prettyprint sequences words ;
|
||||
io kernel namespaces prettyprint prettyprint-internals
|
||||
sequences words ;
|
||||
|
||||
! Help articles
|
||||
SYMBOL: articles
|
||||
|
|
|
|||
|
|
@ -71,8 +71,11 @@ PROVIDE: library
|
|||
|
||||
"compiler/alien/aliens.factor"
|
||||
|
||||
"syntax/prettyprint.factor"
|
||||
"tools/summary.factor"
|
||||
"prettyprint/core.factor"
|
||||
"prettyprint/sections.factor"
|
||||
"prettyprint/backend.factor"
|
||||
"prettyprint/frontend.factor"
|
||||
|
||||
"syntax/parser.factor"
|
||||
"syntax/parse-stream.factor"
|
||||
|
||||
|
|
@ -175,15 +178,17 @@ PROVIDE: library
|
|||
"math/ratio.facts"
|
||||
"math/trig-hyp.facts"
|
||||
"math/vectors.facts"
|
||||
"prettyprint/core.facts"
|
||||
"prettyprint/sections.facts"
|
||||
"prettyprint/backend.facts"
|
||||
"prettyprint/frontend.facts"
|
||||
"syntax/early-parser.facts"
|
||||
"syntax/parse-stream.facts"
|
||||
"syntax/parser.facts"
|
||||
"syntax/parse-syntax.facts"
|
||||
"syntax/prettyprint.facts"
|
||||
"tools/definitions.facts"
|
||||
"tools/word-tools.facts"
|
||||
"tools/debugger.facts"
|
||||
"tools/summary.facts"
|
||||
"tools/describe.facts"
|
||||
"tools/inspector.facts"
|
||||
"tools/listener.facts"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,141 @@
|
|||
! Copyright (C) 2003, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint-internals
|
||||
USING: alien arrays generic hashtables io kernel math
|
||||
namespaces parser sequences strings styles vectors words
|
||||
prettyprint ;
|
||||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
||||
! Atoms
|
||||
M: byte-array pprint* drop "( byte array )" text ;
|
||||
|
||||
: word-style ( word -- style )
|
||||
[
|
||||
dup presented set
|
||||
parsing? [ bold font-style set ] when
|
||||
] make-hash ;
|
||||
|
||||
: pprint-word ( word -- )
|
||||
dup word-name swap word-style styled-text ;
|
||||
|
||||
M: word pprint*
|
||||
dup parsing? [ \ POSTPONE: pprint-word ] when pprint-word ;
|
||||
|
||||
M: real pprint* number>string text ;
|
||||
|
||||
M: f pprint* drop \ f pprint-word ;
|
||||
|
||||
M: alien pprint*
|
||||
dup expired? [
|
||||
drop "( alien expired )"
|
||||
] [
|
||||
\ ALIEN: pprint-word alien-address number>string
|
||||
] if text ;
|
||||
|
||||
! Strings
|
||||
: ch>ascii-escape ( ch -- str )
|
||||
H{
|
||||
{ CHAR: \e "\\e" }
|
||||
{ CHAR: \n "\\n" }
|
||||
{ CHAR: \r "\\r" }
|
||||
{ CHAR: \t "\\t" }
|
||||
{ CHAR: \0 "\\0" }
|
||||
{ CHAR: \\ "\\\\" }
|
||||
{ CHAR: \" "\\\"" }
|
||||
} hash ;
|
||||
|
||||
: ch>unicode-escape ( ch -- str )
|
||||
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
|
||||
|
||||
: unparse-ch ( ch -- )
|
||||
dup quotable? [
|
||||
,
|
||||
] [
|
||||
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
|
||||
] if ;
|
||||
|
||||
: do-string-limit ( str -- trimmed )
|
||||
string-limit get [
|
||||
dup length margin get > [
|
||||
margin get 3 - head "..." append
|
||||
] when
|
||||
] when ;
|
||||
|
||||
: pprint-string ( str prefix -- )
|
||||
[ % [ unparse-ch ] each CHAR: " , ] "" make
|
||||
do-string-limit text ;
|
||||
|
||||
M: string pprint* "\"" pprint-string ;
|
||||
|
||||
M: sbuf pprint* "SBUF\" " pprint-string ;
|
||||
|
||||
M: dll pprint* dll-path "DLL\" " pprint-string ;
|
||||
|
||||
! Sequences
|
||||
: nesting-limit? ( -- ? )
|
||||
nesting-limit get dup [ pprinter-stack get length < ] when ;
|
||||
|
||||
: check-recursion ( obj quot -- )
|
||||
nesting-limit? [
|
||||
2drop "#" text
|
||||
] [
|
||||
over recursion-check get memq? [
|
||||
2drop "&" text
|
||||
] [
|
||||
over recursion-check get push
|
||||
call
|
||||
recursion-check get pop*
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: length-limit? ( seq -- trimmed ? )
|
||||
length-limit get dup
|
||||
[ over length over > [ head t ] [ drop f ] if ]
|
||||
[ drop f ] if ;
|
||||
|
||||
: hilite-style ( -- hash )
|
||||
H{
|
||||
{ background { 0.9 0.9 0.9 1 } }
|
||||
{ highlight t }
|
||||
} ;
|
||||
|
||||
: pprint-hilite ( object n -- )
|
||||
hilite-index get = [
|
||||
hilite-style <flow pprint* block>
|
||||
] [
|
||||
pprint*
|
||||
] if ;
|
||||
|
||||
: pprint-elements ( seq -- )
|
||||
length-limit? >r dup hilite-quotation get eq? [
|
||||
dup length [ pprint-hilite ] 2each
|
||||
] [
|
||||
[ pprint* ] each
|
||||
] if r> [ "..." text ] when ;
|
||||
|
||||
GENERIC: >pprint-sequence ( obj -- seq start end narrow? )
|
||||
|
||||
M: complex >pprint-sequence >rect 2array \ C{ \ } f ;
|
||||
|
||||
M: quotation >pprint-sequence \ [ \ ] f ;
|
||||
|
||||
M: array >pprint-sequence \ { \ } t ;
|
||||
|
||||
M: vector >pprint-sequence \ V{ \ } t ;
|
||||
|
||||
M: hashtable >pprint-sequence hash>alist \ H{ \ } t ;
|
||||
|
||||
M: tuple >pprint-sequence tuple>array \ T{ \ } t ;
|
||||
|
||||
M: wrapper >pprint-sequence
|
||||
wrapped dup 1array swap word? [ \ \ f ] [ \ W{ \ } ] if f ;
|
||||
|
||||
M: object pprint*
|
||||
[
|
||||
>pprint-sequence H{ } <flow
|
||||
rot [ pprint-word ] when*
|
||||
[ H{ } <narrow ] [ H{ } <inset ] if
|
||||
swap pprint-elements
|
||||
block> [ pprint-word ] when* block>
|
||||
] check-recursion ;
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
USING: help io kernel prettyprint prettyprint-internals words ;
|
||||
|
||||
HELP: pprint*
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $contract "Adds sections to the current block corresponding to the prettyprinted representation of the object." }
|
||||
$prettyprinting-note
|
||||
{ $see-also text newline <inset block> } ;
|
||||
|
||||
HELP: pprint-word
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Adds a text section for the word. Unlike the " { $link word } " method of " { $link pprint* } ", this does not add a " { $link POSTPONE: POSTPONE: } " prefix to parsing words." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: ch>ascii-escape
|
||||
{ $values { "ch" "a character" } { "str" "a string" } }
|
||||
{ $description "Converts a character to an escape code." } ;
|
||||
|
||||
HELP: ch>unicode-escape
|
||||
{ $values { "ch" "a character" } { "str" "a string" } }
|
||||
{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u1234"} ")." } ;
|
||||
|
||||
HELP: unparse-ch
|
||||
{ $values { "ch" "a character" } }
|
||||
{ $description "Adds the character to the sequence being constructed (see " { $link "namespaces-make" } "). If the character can appear in a string literal, it is added directly, otherwise an escape code is added." } ;
|
||||
|
||||
HELP: do-string-limit
|
||||
{ $values { "str" "a string" } { "trimmed" "a possibly trimmed string" } }
|
||||
{ $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
|
||||
|
||||
HELP: pprint-string
|
||||
{ $values { "str" "a string" } { "prefix" "a prefix string" } }
|
||||
{ $description "Outputs a text section consisting of the prefix, the string, and a final quote (\")." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: nesting-limit?
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Tests if the " { $link nesting-limit } " has been reached." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: check-recursion
|
||||
{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $description "If the object is already being printed, that is, if the prettyprinter has encountered a cycle in the object graph, or if the maximum nesting depth has been reached, outputs a dummy string. Otherwise applies the quotation to the object." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: length-limit?
|
||||
{ $values { "seq" "a sequence" } { "trimmed" "a trimmed sequence" } { "?" "a boolean indicating if trimming took place" } }
|
||||
{ $description "If the " { $link length-limit } " is set, trims the sequence if necessary, and outputs a boolean indicating if \"...\" should be output." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: pprint-elements
|
||||
{ $values { "seq" "a sequence" } }
|
||||
{ $description "Prettyprints the elements of a sequence, trimming the sequence to " { $link length-limit } " if necessary." }
|
||||
$prettyprinting-note ;
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
! Copyright (C) 2003, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint
|
||||
USING: alien arrays generic hashtables io kernel math
|
||||
namespaces parser sequences strings styles vectors words ;
|
||||
|
||||
! Configuration
|
||||
SYMBOL: tab-size
|
||||
SYMBOL: margin
|
||||
SYMBOL: nesting-limit
|
||||
SYMBOL: length-limit
|
||||
SYMBOL: line-limit
|
||||
SYMBOL: string-limit
|
||||
|
||||
! Special trick to highlight a word in a quotation
|
||||
SYMBOL: hilite-quotation
|
||||
SYMBOL: hilite-index
|
||||
SYMBOL: hilite-next?
|
||||
|
||||
IN: prettyprint-internals
|
||||
|
||||
! State
|
||||
SYMBOL: position
|
||||
SYMBOL: last-newline
|
||||
SYMBOL: recursion-check
|
||||
SYMBOL: line-count
|
||||
SYMBOL: end-printing
|
||||
SYMBOL: indent
|
||||
SYMBOL: pprinter-stack
|
||||
|
||||
! Utility words
|
||||
: line-limit? ( -- ? )
|
||||
line-limit get dup [ line-count get <= ] when ;
|
||||
|
||||
: do-indent ( -- ) indent get CHAR: \s <string> write ;
|
||||
|
||||
: fresh-line ( n -- )
|
||||
dup last-newline get = [
|
||||
drop
|
||||
] [
|
||||
last-newline set
|
||||
line-limit? [ "..." write end-printing get continue ] when
|
||||
line-count inc
|
||||
terpri do-indent
|
||||
] if ;
|
||||
|
||||
: text-fits? ( len -- ? )
|
||||
indent get + margin get <= ;
|
||||
|
||||
global [
|
||||
4 tab-size set
|
||||
64 margin set
|
||||
0 position set
|
||||
0 indent set
|
||||
0 last-newline set
|
||||
1 line-count set
|
||||
string-limit off
|
||||
] bind
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
USING: help io kernel prettyprint prettyprint-internals words ;
|
||||
|
||||
HELP: position
|
||||
{ $var-description "The prettyprinter's current character position." } ;
|
||||
|
||||
HELP: last-newline
|
||||
{ $var-description "The character position of the last newline output by the prettyprinter." } ;
|
||||
|
||||
HELP: recursion-check
|
||||
{ $var-description "The current nesting of collections being output by the prettyprinter, used to detect circularity and prevent infinite recursion." } ;
|
||||
|
||||
HELP: line-count
|
||||
{ $var-description "The number of lines output by the prettyprinter so far, used for line limiting (see " { $link line-limit } ")." } ;
|
||||
|
||||
HELP: end-printing
|
||||
{ $var-description "A continuation captured by " { $link do-pprint } " that breaks out of the printer." } ;
|
||||
|
||||
HELP: indent
|
||||
{ $var-description "The prettyprinter's current indent level." } ;
|
||||
|
||||
HELP: pprinter-stack
|
||||
{ $var-description "A stack of " { $link block } " objects currently being constructed by the prettyprinter." } ;
|
||||
|
||||
HELP: tab-size
|
||||
{ $var-description "Prettyprinter tab size. Indent nesting is always a multiple of the tab size. The default is 4." } ;
|
||||
|
||||
HELP: margin
|
||||
{ $var-description "The maximum line length, in characters. Lines longer than the margin are wrapped. The default is 64." } ;
|
||||
|
||||
HELP: nesting-limit
|
||||
{ $var-description "The maximum nesting level. Structures that nest further than this will simply print as a pound sign (#). The default is " { $link f } ", denoting unlimited nesting depth." } ;
|
||||
|
||||
HELP: length-limit
|
||||
{ $var-description "The maximum printed sequence length. Sequences longer than this are truncated, and \"...\" is output in place of remaining elements. The default is " { $link f } ", denoting unlimited sequence length." } ;
|
||||
|
||||
HELP: line-limit
|
||||
{ $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ;
|
||||
|
||||
HELP: string-limit
|
||||
{ $var-description "Toggles whenever printed strings are truncated to the margin." } ;
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
! Copyright (C) 2003, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint
|
||||
USING: alien arrays generic hashtables io kernel math
|
||||
namespaces parser sequences strings styles vectors words
|
||||
prettyprint-internals ;
|
||||
|
||||
: with-pprint ( quot -- )
|
||||
[
|
||||
V{ } clone recursion-check set
|
||||
H{ } <flow> f ?push pprinter-stack set
|
||||
call end-blocks do-pprint
|
||||
] with-scope ; inline
|
||||
|
||||
: pprint ( obj -- ) [ pprint* ] with-pprint ;
|
||||
|
||||
: . ( obj -- )
|
||||
H{
|
||||
{ length-limit 1000 }
|
||||
{ nesting-limit 10 }
|
||||
} clone [ pprint ] bind terpri ;
|
||||
|
||||
: unparse ( obj -- str ) [ pprint ] string-out ;
|
||||
|
||||
: pprint-short ( obj -- )
|
||||
H{
|
||||
{ line-limit 1 }
|
||||
{ length-limit 15 }
|
||||
{ nesting-limit 2 }
|
||||
{ string-limit t }
|
||||
} clone [ pprint ] bind ;
|
||||
|
||||
: short. ( obj -- ) pprint-short terpri ;
|
||||
|
||||
: unparse-short ( obj -- str ) [ pprint-short ] string-out ;
|
||||
|
||||
: .b ( n -- ) >bin print ;
|
||||
: .o ( n -- ) >oct print ;
|
||||
: .h ( n -- ) >hex print ;
|
||||
|
||||
GENERIC: summary ( object -- string )
|
||||
|
||||
M: object summary
|
||||
"an instance of the " swap class word-name " class" append3 ;
|
||||
|
||||
M: input summary
|
||||
"Input: " swap input-string dup string?
|
||||
[ "\n" split1 "..." "" ? append ] [ unparse-short ] if
|
||||
append ;
|
||||
|
||||
M: vocab-link summary
|
||||
[
|
||||
vocab-link-name dup %
|
||||
" vocabulary (" %
|
||||
words length #
|
||||
" words)" %
|
||||
] "" make ;
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
IN: prettyprint
|
||||
USING: help io kernel prettyprint prettyprint-internals words ;
|
||||
|
||||
HELP: with-pprint
|
||||
{ $values { "quot" "a 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 the default stream." } ;
|
||||
|
||||
HELP: pprint
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: .
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: unparse
|
||||
{ $values { "obj" "an object" } { "str" "Factor source string" } }
|
||||
{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: pprint-short
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: short.
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
|
||||
|
||||
HELP: unparse-short
|
||||
{ $values { "obj" "an object" } { "str" "Factor source string" } }
|
||||
{ $description "Outputs a prettyprinted string representation of an object. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: .b
|
||||
{ $values { "n" "an integer" } }
|
||||
{ $description "Outputs an integer in binary." } ;
|
||||
|
||||
HELP: .o
|
||||
{ $values { "n" "an integer" } }
|
||||
{ $description "Outputs an integer in octal." } ;
|
||||
|
||||
HELP: .h
|
||||
{ $values { "n" "an integer" } }
|
||||
{ $description "Outputs an integer in hexadecimal." } ;
|
||||
|
||||
HELP: summary
|
||||
{ $values { "object" "an object" } { "string" "a string" } }
|
||||
{ $contract "Outputs a brief description of the object." } ;
|
||||
|
|
@ -0,0 +1,217 @@
|
|||
! Copyright (C) 2003, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint-internals
|
||||
USING: alien arrays generic hashtables io kernel math
|
||||
namespaces parser sequences strings styles vectors words
|
||||
prettyprint ;
|
||||
|
||||
! Sections
|
||||
TUPLE: section start end style ;
|
||||
|
||||
C: section ( style length -- section )
|
||||
>r position [ dup rot + dup ] change r>
|
||||
[ set-section-end ] keep
|
||||
[ set-section-start ] keep
|
||||
[ set-section-style ] keep ;
|
||||
|
||||
GENERIC: section-fits? ( section -- ? )
|
||||
|
||||
M: section section-fits? ( section -- ? )
|
||||
section-end last-newline get - text-fits? ;
|
||||
|
||||
GENERIC: short-section ( section -- )
|
||||
|
||||
GENERIC: long-section ( section -- )
|
||||
|
||||
GENERIC: block-empty? ( section -- ? )
|
||||
|
||||
: pprint-section ( section -- )
|
||||
{
|
||||
{ [ margin get zero? ] [ short-section ] }
|
||||
{ [ dup section-fits? ] [ short-section ] }
|
||||
{ [ t ] [ long-section ] }
|
||||
} cond ;
|
||||
|
||||
! Block sections
|
||||
TUPLE: block sections ;
|
||||
|
||||
C: block ( style -- block )
|
||||
swap 0 <section> over set-delegate
|
||||
V{ } clone over set-block-sections ;
|
||||
|
||||
: pprinter-block ( -- block ) pprinter-stack get peek ;
|
||||
|
||||
: add-section ( section -- )
|
||||
dup block-empty?
|
||||
[ drop ] [ pprinter-block block-sections push ] if ;
|
||||
|
||||
M: block block-empty? block-sections empty? ;
|
||||
|
||||
M: block section-fits? ( section -- ? )
|
||||
line-limit? [
|
||||
drop t
|
||||
] [
|
||||
delegate section-fits?
|
||||
] if ;
|
||||
|
||||
: (<block) pprinter-stack get push ;
|
||||
|
||||
: <style section-style stdio [ <nested-style-stream> ] change ;
|
||||
|
||||
: style> stdio [ delegate ] change ;
|
||||
|
||||
: change-indent ( n -- )
|
||||
tab-size get * indent [ + ] change ;
|
||||
|
||||
: <indent ( block -- ) 1 change-indent ;
|
||||
|
||||
: indent> ( block -- ) -1 change-indent ;
|
||||
|
||||
! Text section
|
||||
TUPLE: text string ;
|
||||
|
||||
C: text ( string style -- text )
|
||||
[ >r over length 1+ <section> r> set-delegate ] keep
|
||||
[ set-text-string ] keep ;
|
||||
|
||||
M: text block-empty? drop f ;
|
||||
|
||||
M: text short-section
|
||||
dup text-string swap section-style format ;
|
||||
|
||||
M: text long-section
|
||||
dup section-start fresh-line short-section ;
|
||||
|
||||
: styled-text ( string style -- ) <text> add-section ;
|
||||
|
||||
: text ( string -- ) H{ } styled-text ;
|
||||
|
||||
! Newline section
|
||||
TUPLE: newline ;
|
||||
|
||||
C: newline ( -- section )
|
||||
H{ } 0 <section> over set-delegate ;
|
||||
|
||||
M: newline block-empty? drop f ;
|
||||
|
||||
M: newline section-fits? drop t ;
|
||||
|
||||
M: newline short-section section-start fresh-line ;
|
||||
|
||||
: newline ( -- ) <newline> add-section ;
|
||||
|
||||
! Inset section
|
||||
TUPLE: inset ;
|
||||
|
||||
C: inset ( style -- block )
|
||||
swap <block> over set-delegate ;
|
||||
|
||||
M: inset section-fits? ( section -- ? )
|
||||
line-limit? [
|
||||
drop t
|
||||
] [
|
||||
section-end last-newline get - 2 + text-fits?
|
||||
] if ;
|
||||
|
||||
: advance ( section -- )
|
||||
dup newline? [
|
||||
drop
|
||||
] [
|
||||
section-start last-newline get = [ bl ] unless
|
||||
] if ;
|
||||
|
||||
: pprint-block ( block -- )
|
||||
dup <style
|
||||
block-sections unclip pprint-section
|
||||
[ dup advance pprint-section ] each
|
||||
style> ;
|
||||
|
||||
M: inset short-section pprint-block ;
|
||||
|
||||
M: inset long-section
|
||||
<indent
|
||||
dup section-start fresh-line dup pprint-block
|
||||
indent>
|
||||
section-end fresh-line ;
|
||||
|
||||
: <inset ( style -- ) <inset> (<block) ;
|
||||
|
||||
! Flow section
|
||||
TUPLE: flow ;
|
||||
|
||||
C: flow ( style -- block )
|
||||
swap <block> over set-delegate ;
|
||||
|
||||
M: flow section-fits? ( section -- ? )
|
||||
dup delegate section-fits? [
|
||||
drop t
|
||||
] [
|
||||
dup section-end swap section-start - text-fits? not
|
||||
] if ;
|
||||
|
||||
M: flow short-section pprint-block ;
|
||||
|
||||
M: flow long-section dup section-start fresh-line pprint-block ;
|
||||
|
||||
: <flow ( style -- ) <flow> (<block) ;
|
||||
|
||||
! Narrow section
|
||||
TUPLE: narrow ;
|
||||
|
||||
C: narrow ( style -- block )
|
||||
swap <block> over set-delegate ;
|
||||
|
||||
M: narrow section-fits? ( section -- ? )
|
||||
line-limit? [
|
||||
drop t
|
||||
] [
|
||||
section-end last-newline get - 2 + text-fits?
|
||||
] if ;
|
||||
|
||||
M: narrow short-section pprint-block ;
|
||||
|
||||
: narrow-block ( block -- )
|
||||
dup <style
|
||||
block-sections unclip pprint-section
|
||||
[ dup section-start fresh-line pprint-section ] each
|
||||
style> ;
|
||||
|
||||
M: narrow long-section
|
||||
<indent
|
||||
dup section-start fresh-line dup narrow-block
|
||||
indent>
|
||||
section-end fresh-line ;
|
||||
|
||||
: <narrow ( style -- ) <narrow> (<block) ;
|
||||
|
||||
! Defblock section
|
||||
TUPLE: defblock ;
|
||||
|
||||
C: defblock ( style -- block )
|
||||
swap <block> over set-delegate ;
|
||||
|
||||
M: defblock short-section pprint-block ;
|
||||
|
||||
M: defblock long-section
|
||||
<indent
|
||||
dup section-start fresh-line pprint-block
|
||||
indent> ;
|
||||
|
||||
: <defblock ( style -- ) <defblock> (<block) ;
|
||||
|
||||
: end-block ( block -- ) position get swap set-section-end ;
|
||||
|
||||
: (block>) ( -- )
|
||||
pprinter-stack get pop dup end-block add-section ;
|
||||
|
||||
: last-block? ( -- ? ) pprinter-stack get length 1 = ;
|
||||
|
||||
: block> ( -- ) last-block? [ (block>) ] unless ;
|
||||
|
||||
: end-blocks ( -- ) last-block? [ (block>) end-blocks ] unless ;
|
||||
|
||||
: do-pprint ( -- )
|
||||
[
|
||||
end-printing set pprinter-block
|
||||
dup block-empty? [ drop ] [ pprint-section ] if
|
||||
] callcc0 ;
|
||||
|
|
@ -0,0 +1,103 @@
|
|||
USING: help io kernel prettyprint prettyprint-internals words ;
|
||||
|
||||
: $prettyprinting-note
|
||||
drop {
|
||||
"This word should only be called from inside the "
|
||||
{ $link with-pprint } " combinator."
|
||||
} $notes ;
|
||||
|
||||
HELP: pprint-section
|
||||
{ $values { "section" "a section" } }
|
||||
{ $contract "Prettyprints an object delegating to an instance of " { $link section } ", performing wrapping and indentation using the formatting information in the section." } ;
|
||||
|
||||
HELP: section
|
||||
{ $class-description "A section represents a run of text with a known length and indentation level." } ;
|
||||
|
||||
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 the default stream." } ;
|
||||
|
||||
HELP: fresh-line
|
||||
{ $values { "n" "the current column position" } }
|
||||
{ $description "Advances the prettyprinter by one line unless the current line is empty. If the line limit is exceeded, escapes the prettyprinter by restoring a continuation captured in " { $link do-pprint } "." } ;
|
||||
|
||||
HELP: <text>
|
||||
{ $values { "string" "a string" } { "style" "a hashtable" } { "text" "a new text section" } }
|
||||
{ $description "Creates a text section." } ;
|
||||
|
||||
HELP: block
|
||||
{ $class-description "A block is a section consisting of whitespace-separated child sections." } ;
|
||||
|
||||
HELP: pprinter-block
|
||||
{ $values { "block" "a block section" } }
|
||||
{ $description "Outputs the block currently being constructed." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: block-empty?
|
||||
{ $values { "section" "a section" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a section is empty. A section is empty if it is a block with no children." } ;
|
||||
|
||||
HELP: add-section
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Adds a section to the current block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: text
|
||||
{ $values { "string" "a string" } }
|
||||
{ $description "Adds a section consisting of a single string to the current block. The current style on the style stack is used; see " { $link with-style } "." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: <indent
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Increases indent level by the indent level of the section." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: indent>
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Decreases indent level by the indent level of the section." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: section-fits?
|
||||
{ $values { "section" "a section" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a section should be printed on the current line." } ;
|
||||
|
||||
HELP: newline
|
||||
{ $description "Adds a section introducing an unconditional line break to the current block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: advance
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Emits a space unless the section is the first section on the line." } ;
|
||||
|
||||
HELP: <inset
|
||||
{ $values { "style" "a style" } }
|
||||
{ $description "Begins a nested block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: end-block
|
||||
{ $values { "block" "a block" } }
|
||||
{ $description "Save the current position as the end position of the block." } ;
|
||||
|
||||
HELP: (block>)
|
||||
{ $description "Adds the current block to its containing block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: last-block?
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Tests if the current block is the top-level block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: block>
|
||||
{ $description "Adds the current block to its containing block, unless the current block is the top-level block in which case it does nothing." }
|
||||
{ $notes "This word is used to end blocks in order for the prettyprinter to be forgiving in the case of mismatched begin/end pairs (this can happen when printing parsing words)." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: end-blocks
|
||||
{ $description "Unwind all prettyprinter state to the top level block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: do-pprint
|
||||
{ $description "Recursively output all children of the top-level block. The continuation is restored and output terminates if the line length is exceeded; this test is performed in " { $link fresh-line } "." } ;
|
||||
|
|
@ -1,357 +0,0 @@
|
|||
! Copyright (C) 2003, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint
|
||||
USING: alien arrays generic hashtables io kernel math
|
||||
namespaces parser sequences strings styles vectors words ;
|
||||
|
||||
! State
|
||||
SYMBOL: position
|
||||
SYMBOL: last-newline
|
||||
SYMBOL: recursion-check
|
||||
SYMBOL: line-count
|
||||
SYMBOL: end-printing
|
||||
SYMBOL: indent
|
||||
SYMBOL: pprinter-stack
|
||||
|
||||
! Configuration
|
||||
SYMBOL: tab-size
|
||||
SYMBOL: margin
|
||||
SYMBOL: nesting-limit
|
||||
SYMBOL: length-limit
|
||||
SYMBOL: line-limit
|
||||
SYMBOL: string-limit
|
||||
|
||||
! Special trick to highlight a word in a quotation
|
||||
SYMBOL: hilite-quotation
|
||||
SYMBOL: hilite-index
|
||||
SYMBOL: hilite-next?
|
||||
|
||||
global [
|
||||
4 tab-size set
|
||||
64 margin set
|
||||
0 position set
|
||||
0 indent set
|
||||
0 last-newline set
|
||||
1 line-count set
|
||||
string-limit off
|
||||
] bind
|
||||
|
||||
GENERIC: pprint-section* ( section -- )
|
||||
|
||||
TUPLE: section start end nl-after? indent style ;
|
||||
|
||||
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? ( -- ? )
|
||||
line-limit get dup [ line-count get <= ] when ;
|
||||
|
||||
: do-indent ( -- ) indent get CHAR: \s <string> write ;
|
||||
|
||||
: fresh-line ( n -- )
|
||||
dup last-newline get = [
|
||||
drop
|
||||
] [
|
||||
last-newline set
|
||||
line-limit? [ "..." write end-printing get continue ] when
|
||||
line-count inc
|
||||
terpri do-indent
|
||||
] if ;
|
||||
|
||||
TUPLE: text string ;
|
||||
|
||||
C: text ( string style -- text )
|
||||
[ >r over length 1+ <section> r> set-delegate ] keep
|
||||
[ set-text-string ] keep ;
|
||||
|
||||
M: text pprint-section*
|
||||
dup text-string swap section-style format ;
|
||||
|
||||
TUPLE: block sections ;
|
||||
|
||||
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 ;
|
||||
|
||||
: pprinter-block ( -- block ) pprinter-stack get peek ;
|
||||
|
||||
: block-empty? ( section -- ? )
|
||||
dup block? [ block-sections empty? ] [ drop f ] if ;
|
||||
|
||||
: add-section ( section -- )
|
||||
dup block-empty?
|
||||
[ drop ] [ pprinter-block block-sections push ] if ;
|
||||
|
||||
: styled-text ( string style -- ) <text> add-section ;
|
||||
|
||||
: text ( string -- ) H{ } styled-text ;
|
||||
|
||||
: <indent ( section -- ) section-indent indent [ + ] change ;
|
||||
|
||||
: indent> ( section -- ) section-indent indent [ swap - ] change ;
|
||||
|
||||
: inset-section ( section -- )
|
||||
dup <indent
|
||||
dup section-start fresh-line dup pprint-section*
|
||||
dup indent>
|
||||
dup section-nl-after?
|
||||
[ section-end fresh-line ] [ drop ] if ;
|
||||
|
||||
: section-fits? ( section -- ? )
|
||||
margin get dup zero? [
|
||||
2drop t
|
||||
] [
|
||||
line-limit? pick block? and [
|
||||
2drop t
|
||||
] [
|
||||
>r section-end last-newline get - indent get + r> <=
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: pprint-section ( section -- )
|
||||
dup section-fits? [ pprint-section* ] [ inset-section ] if ;
|
||||
|
||||
TUPLE: newline ;
|
||||
|
||||
C: newline ( -- section )
|
||||
H{ } 0 <section> over set-delegate ;
|
||||
|
||||
M: newline pprint-section*
|
||||
section-start fresh-line ;
|
||||
|
||||
: newline ( -- ) <newline> add-section ;
|
||||
|
||||
: advance ( section -- )
|
||||
dup newline? [
|
||||
drop
|
||||
] [
|
||||
section-start last-newline get = [ bl ] unless
|
||||
] if ;
|
||||
|
||||
: <style section-style stdio [ <nested-style-stream> ] change ;
|
||||
|
||||
: style> stdio [ delegate ] change ;
|
||||
|
||||
M: block pprint-section*
|
||||
dup <style
|
||||
f swap block-sections [
|
||||
over [ dup advance ] when pprint-section drop t
|
||||
] each drop
|
||||
style> ;
|
||||
|
||||
: <block ( style -- ) <block> pprinter-stack get push ;
|
||||
|
||||
: end-block ( block -- ) position get swap set-section-end ;
|
||||
|
||||
: (block>) ( -- )
|
||||
pprinter-stack get pop dup end-block add-section ;
|
||||
|
||||
: last-block? ( -- ? ) pprinter-stack get length 1 = ;
|
||||
|
||||
: block> ( -- ) last-block? [ (block>) ] unless ;
|
||||
|
||||
: block; ( -- )
|
||||
pprinter-block f swap set-section-nl-after? block> ;
|
||||
|
||||
: end-blocks ( -- ) last-block? [ (block>) end-blocks ] unless ;
|
||||
|
||||
: do-pprint ( -- )
|
||||
[ end-printing set pprinter-block pprint-section ] callcc0 ;
|
||||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
||||
: word-style ( word -- style )
|
||||
[
|
||||
dup presented set
|
||||
parsing? [ bold font-style set ] when
|
||||
] make-hash ;
|
||||
|
||||
: pprint-word ( word -- )
|
||||
dup word-name swap word-style styled-text ;
|
||||
|
||||
M: object pprint*
|
||||
"( unprintable object: " swap class word-name " )" append3
|
||||
text ;
|
||||
|
||||
M: real pprint* number>string text ;
|
||||
|
||||
: ch>ascii-escape ( ch -- str )
|
||||
H{
|
||||
{ CHAR: \e "\\e" }
|
||||
{ CHAR: \n "\\n" }
|
||||
{ CHAR: \r "\\r" }
|
||||
{ CHAR: \t "\\t" }
|
||||
{ CHAR: \0 "\\0" }
|
||||
{ CHAR: \\ "\\\\" }
|
||||
{ CHAR: \" "\\\"" }
|
||||
} hash ;
|
||||
|
||||
: ch>unicode-escape ( ch -- str )
|
||||
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
|
||||
|
||||
: unparse-ch ( ch -- )
|
||||
dup quotable? [
|
||||
,
|
||||
] [
|
||||
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
|
||||
] if ;
|
||||
|
||||
: do-string-limit ( str -- trimmed )
|
||||
string-limit get [
|
||||
dup length margin get > [
|
||||
margin get 3 - head "..." append
|
||||
] when
|
||||
] when ;
|
||||
|
||||
: pprint-string ( str prefix -- )
|
||||
[ % [ unparse-ch ] each CHAR: " , ] "" make
|
||||
do-string-limit text ;
|
||||
|
||||
M: string pprint* "\"" pprint-string ;
|
||||
|
||||
M: sbuf pprint* "SBUF\" " pprint-string ;
|
||||
|
||||
M: word pprint*
|
||||
dup "pprint-close" word-prop [ block> ] when
|
||||
dup pprint-word
|
||||
"pprint-open" word-prop [ H{ } <block ] when ;
|
||||
|
||||
M: f pprint* drop \ f pprint-word ;
|
||||
|
||||
M: dll pprint* dll-path "DLL\" " pprint-string ;
|
||||
|
||||
: nesting-limit? ( -- ? )
|
||||
nesting-limit get dup [ pprinter-stack get length < ] when ;
|
||||
|
||||
: check-recursion ( obj quot -- )
|
||||
nesting-limit? [
|
||||
2drop "#" text
|
||||
] [
|
||||
over recursion-check get memq? [
|
||||
2drop "&" text
|
||||
] [
|
||||
over recursion-check get push
|
||||
call
|
||||
recursion-check get pop*
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: length-limit? ( seq -- trimmed ? )
|
||||
length-limit get dup
|
||||
[ over length over > [ head t ] [ drop f ] if ]
|
||||
[ drop f ] if ;
|
||||
|
||||
: pprint-element ( obj -- )
|
||||
dup parsing? [ \ POSTPONE: pprint-word ] when pprint* ;
|
||||
|
||||
: hilite-style ( -- hash )
|
||||
H{
|
||||
{ background { 0.9 0.9 0.9 1 } }
|
||||
{ highlight t }
|
||||
} ;
|
||||
|
||||
: pprint-hilite ( object n -- )
|
||||
hilite-index get = [
|
||||
hilite-style <block pprint-element block>
|
||||
] [
|
||||
pprint-element
|
||||
] if ;
|
||||
|
||||
: pprint-elements ( seq -- )
|
||||
length-limit? >r dup hilite-quotation get eq? [
|
||||
dup length [ pprint-hilite ] 2each
|
||||
] [
|
||||
[ pprint-element ] each
|
||||
] if r> [ "..." text ] when ;
|
||||
|
||||
: pprint-sequence ( seq start end -- )
|
||||
swap pprint* swap pprint-elements pprint* ;
|
||||
|
||||
M: complex pprint*
|
||||
>rect 2array \ C{ \ } pprint-sequence ;
|
||||
|
||||
M: quotation pprint*
|
||||
[ \ [ \ ] pprint-sequence ] check-recursion ;
|
||||
|
||||
M: array pprint*
|
||||
[ \ { \ } pprint-sequence ] check-recursion ;
|
||||
|
||||
M: vector pprint*
|
||||
[ \ V{ \ } pprint-sequence ] check-recursion ;
|
||||
|
||||
M: hashtable pprint*
|
||||
[ hash>alist \ H{ \ } pprint-sequence ] check-recursion ;
|
||||
|
||||
M: tuple pprint*
|
||||
[
|
||||
\ T{ pprint*
|
||||
tuple>array dup first pprint*
|
||||
H{ } <block 1 tail-slice pprint-elements
|
||||
\ } pprint*
|
||||
] check-recursion ;
|
||||
|
||||
M: alien pprint*
|
||||
dup expired? [
|
||||
drop "( alien expired )"
|
||||
] [
|
||||
\ ALIEN: pprint-word alien-address number>string
|
||||
] if text ;
|
||||
|
||||
M: wrapper pprint*
|
||||
dup wrapped word? [
|
||||
\ \ pprint-word wrapped pprint-word
|
||||
] [
|
||||
wrapped 1array \ W{ \ } pprint-sequence
|
||||
] if ;
|
||||
|
||||
: with-pprint ( quot -- )
|
||||
[
|
||||
V{ } clone recursion-check set
|
||||
H{ } <block> f ?push pprinter-stack set
|
||||
call end-blocks do-pprint
|
||||
] with-scope ; inline
|
||||
|
||||
: pprint ( obj -- ) [ pprint* ] with-pprint ;
|
||||
|
||||
: . ( obj -- )
|
||||
H{
|
||||
{ length-limit 1000 }
|
||||
{ nesting-limit 10 }
|
||||
} clone [ pprint ] bind terpri ;
|
||||
|
||||
: unparse ( obj -- str ) [ pprint ] string-out ;
|
||||
|
||||
: pprint-short ( obj -- )
|
||||
H{
|
||||
{ line-limit 1 }
|
||||
{ length-limit 15 }
|
||||
{ nesting-limit 2 }
|
||||
{ string-limit t }
|
||||
} clone [ pprint ] bind ;
|
||||
|
||||
: short. ( obj -- ) pprint-short terpri ;
|
||||
|
||||
: unparse-short ( obj -- str ) [ pprint-short ] string-out ;
|
||||
|
||||
: .b ( n -- ) >bin print ;
|
||||
: .o ( n -- ) >oct print ;
|
||||
: .h ( n -- ) >hex print ;
|
||||
|
||||
: define-open ( word -- ) t "pprint-open" set-word-prop ;
|
||||
: define-close ( word -- ) t "pprint-close" set-word-prop ;
|
||||
|
||||
{
|
||||
POSTPONE: [
|
||||
POSTPONE: { POSTPONE: V{ POSTPONE: H{
|
||||
POSTPONE: W{
|
||||
} [ define-open ] each
|
||||
|
||||
{
|
||||
POSTPONE: ] POSTPONE: }
|
||||
} [ define-close ] each
|
||||
|
|
@ -1,266 +0,0 @@
|
|||
USING: help io kernel prettyprint words ;
|
||||
|
||||
IN: help
|
||||
|
||||
: $prettyprinting-note
|
||||
drop {
|
||||
"This word should only be called from inside the "
|
||||
{ $link with-pprint } " combinator."
|
||||
} $notes ;
|
||||
|
||||
HELP: position
|
||||
{ $var-description "The prettyprinter's current character position." } ;
|
||||
|
||||
HELP: last-newline
|
||||
{ $var-description "The character position of the last newline output by the prettyprinter." } ;
|
||||
|
||||
HELP: recursion-check
|
||||
{ $var-description "The current nesting of collections being output by the prettyprinter, used to detect circularity and prevent infinite recursion." } ;
|
||||
|
||||
HELP: line-count
|
||||
{ $var-description "The number of lines output by the prettyprinter so far, used for line limiting (see " { $link line-limit } ")." } ;
|
||||
|
||||
HELP: end-printing
|
||||
{ $var-description "A continuation captured by " { $link do-pprint } " that breaks out of the printer." } ;
|
||||
|
||||
HELP: indent
|
||||
{ $var-description "The prettyprinter's current indent level." } ;
|
||||
|
||||
HELP: pprinter-stack
|
||||
{ $var-description "A stack of " { $link block } " objects currently being constructed by the prettyprinter." } ;
|
||||
|
||||
HELP: tab-size
|
||||
{ $var-description "Prettyprinter tab size. Indent nesting is always a multiple of the tab size. The default is 4." } ;
|
||||
|
||||
HELP: margin
|
||||
{ $var-description "The maximum line length, in characters. Lines longer than the margin are wrapped. The default is 64." } ;
|
||||
|
||||
HELP: nesting-limit
|
||||
{ $var-description "The maximum nesting level. Structures that nest further than this will simply print as a pound sign (#). The default is " { $link f } ", denoting unlimited nesting depth." } ;
|
||||
|
||||
HELP: length-limit
|
||||
{ $var-description "The maximum printed sequence length. Sequences longer than this are truncated, and \"...\" is output in place of remaining elements. The default is " { $link f } ", denoting unlimited sequence length." } ;
|
||||
|
||||
HELP: line-limit
|
||||
{ $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ;
|
||||
|
||||
HELP: string-limit
|
||||
{ $var-description "Toggles whenever printed strings are truncated to the margin." } ;
|
||||
|
||||
HELP: pprint-section*
|
||||
{ $values { "section" "a section" } }
|
||||
{ $contract "Prettyprints an object delegating to an instance of " { $link section } ", performing wrapping and indentation using the formatting information in the section." } ;
|
||||
|
||||
HELP: section
|
||||
{ $class-description "A section represents a run of text with a known length and indentation level." } ;
|
||||
|
||||
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 the default stream." } ;
|
||||
|
||||
HELP: fresh-line
|
||||
{ $values { "n" "the current column position" } }
|
||||
{ $description "Advances the prettyprinter by one line unless the current line is empty. If the line limit is exceeded, escapes the prettyprinter by restoring a continuation captured in " { $link do-pprint } "." } ;
|
||||
|
||||
HELP: <text>
|
||||
{ $values { "string" "a string" } { "style" "a hashtable" } { "text" "a new text section" } }
|
||||
{ $description "Creates a text section." } ;
|
||||
|
||||
HELP: block
|
||||
{ $class-description "A block is a section consisting of whitespace-separated child sections." } ;
|
||||
|
||||
HELP: pprinter-block
|
||||
{ $values { "block" "a block section" } }
|
||||
{ $description "Outputs the block currently being constructed." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: block-empty?
|
||||
{ $values { "section" "a section" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a section is empty. A section is empty if it is a block with no children." } ;
|
||||
|
||||
HELP: add-section
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Adds a section to the current block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: text
|
||||
{ $values { "string" "a string" } }
|
||||
{ $description "Adds a section consisting of a single string to the current block. The current style on the style stack is used; see " { $link with-style } "." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: <indent
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Increases indent level by the indent level of the section." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: indent>
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Decreases indent level by the indent level of the section." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: inset-section
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Prints a section surrounded by line breaks and with increased indent." } ;
|
||||
|
||||
HELP: section-fits?
|
||||
{ $values { "section" "a section" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a section should be printed on the current line." } ;
|
||||
|
||||
HELP: pprint-section
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Prints a section, with a line break and increase in indent level if necessary." } ;
|
||||
|
||||
HELP: newline
|
||||
{ $description "Adds a section introducing an unconditional line break to the current block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: advance
|
||||
{ $values { "section" "a section" } }
|
||||
{ $description "Emits a space unless the section is the first section on the line." } ;
|
||||
|
||||
HELP: <block
|
||||
{ $values { "style" "a style" } }
|
||||
{ $description "Begins a nested block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: end-block
|
||||
{ $values { "block" "a block" } }
|
||||
{ $description "Save the current position as the end position of the block." } ;
|
||||
|
||||
HELP: (block>)
|
||||
{ $description "Adds the current block to its containing block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: last-block?
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Tests if the current block is the top-level block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: block>
|
||||
{ $description "Adds the current block to its containing block, unless the current block is the top-level block in which case it does nothing." }
|
||||
{ $notes "This word is used to end blocks in order for the prettyprinter to be forgiving in the case of mismatched begin/end pairs (this can happen when printing parsing words)." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: block;
|
||||
{ $description "Adds the current block to its containing block. The current block will be terminated by an unconditional newline." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: end-blocks
|
||||
{ $description "Unwind all prettyprinter state to the top level block." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: do-pprint
|
||||
{ $description "Recursively output all children of the top-level block. The continuation is restored and output terminates if the line length is exceeded; this test is performed in " { $link fresh-line } "." } ;
|
||||
|
||||
HELP: pprint*
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $contract "Adds sections to the current block corresponding to the prettyprinted representation of the object." }
|
||||
$prettyprinting-note
|
||||
{ $see-also text newline <block block> block; } ;
|
||||
|
||||
HELP: pprint-word
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Adds a text section for the word. Unlike the " { $link word } " method of " { $link pprint* } ", this does not add a " { $link POSTPONE: POSTPONE: } " prefix to parsing words." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: ch>ascii-escape
|
||||
{ $values { "ch" "a character" } { "str" "a string" } }
|
||||
{ $description "Converts a character to an escape code." } ;
|
||||
|
||||
HELP: ch>unicode-escape
|
||||
{ $values { "ch" "a character" } { "str" "a string" } }
|
||||
{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u1234"} ")." } ;
|
||||
|
||||
HELP: unparse-ch
|
||||
{ $values { "ch" "a character" } }
|
||||
{ $description "Adds the character to the sequence being constructed (see " { $link "namespaces-make" } "). If the character can appear in a string literal, it is added directly, otherwise an escape code is added." } ;
|
||||
|
||||
HELP: do-string-limit
|
||||
{ $values { "str" "a string" } { "trimmed" "a possibly trimmed string" } }
|
||||
{ $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
|
||||
|
||||
HELP: pprint-string
|
||||
{ $values { "str" "a string" } { "prefix" "a prefix string" } }
|
||||
{ $description "Outputs a text section consisting of the prefix, the string, and a final quote (\")." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: nesting-limit?
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Tests if the " { $link nesting-limit } " has been reached." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: check-recursion
|
||||
{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $description "If the object is already being printed, that is, if the prettyprinter has encountered a cycle in the object graph, or if the maximum nesting depth has been reached, outputs a dummy string. Otherwise applies the quotation to the object." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: length-limit?
|
||||
{ $values { "seq" "a sequence" } { "trimmed" "a trimmed sequence" } { "?" "a boolean indicating if trimming took place" } }
|
||||
{ $description "If the " { $link length-limit } " is set, trims the sequence if necessary, and outputs a boolean indicating if \"...\" should be output." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: pprint-element
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints a sequence element." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: pprint-elements
|
||||
{ $values { "seq" "a sequence" } }
|
||||
{ $description "Prettyprints the elements of a sequence, trimming the sequence to " { $link length-limit } " if necessary." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: pprint-sequence
|
||||
{ $values { "seq" "a sequence" } { "start" "a word" } { "end" "a word" } }
|
||||
{ $description "Prettyprints a sequence." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
HELP: with-pprint
|
||||
{ $values { "quot" "a 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 the default stream." } ;
|
||||
|
||||
HELP: pprint
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: .
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: unparse
|
||||
{ $values { "obj" "an object" } { "str" "Factor source string" } }
|
||||
{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: pprint-short
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: short.
|
||||
{ $values { "obj" "an object" } }
|
||||
{ $description "Prettyprints an object to the default stream with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
|
||||
|
||||
HELP: unparse-short
|
||||
{ $values { "obj" "an object" } { "str" "Factor source string" } }
|
||||
{ $description "Outputs a prettyprinted string representation of an object. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
|
||||
|
||||
HELP: .b
|
||||
{ $values { "n" "an integer" } }
|
||||
{ $description "Outputs an integer in binary." } ;
|
||||
|
||||
HELP: .o
|
||||
{ $values { "n" "an integer" } }
|
||||
{ $description "Outputs an integer in octal." } ;
|
||||
|
||||
HELP: .h
|
||||
{ $values { "n" "an integer" } }
|
||||
{ $description "Outputs an integer in hexadecimal." } ;
|
||||
|
||||
HELP: define-open
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Marks up the word so that it begins a nested block when prettyprinted. Usually only used for parsing words." } ;
|
||||
|
||||
HELP: define-close
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Marks up the word so that it ends a nested block when prettyprinted. Usually only used for parsing words." } ;
|
||||
|
|
@ -120,7 +120,7 @@ TUPLE: another-one ;
|
|||
[ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
|
||||
|
||||
! Test generic see and parsing
|
||||
[ "IN: temporary SYMBOL: bah\nUNION: bah fixnum alien ;\n" ]
|
||||
[ "IN: temporary SYMBOL: bah\n\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] string-out ] unit-test
|
||||
|
||||
! Weird bug
|
||||
|
|
|
|||
|
|
@ -32,15 +32,6 @@ unit-test
|
|||
|
||||
[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test
|
||||
|
||||
: foo ( a -- b ) dup * ; inline
|
||||
|
||||
[ "IN: temporary : foo ( a -- b ) dup * ; inline\n" ]
|
||||
[ [ \ foo see ] string-out ] unit-test
|
||||
|
||||
: bar ( x -- y ) 2 + ;
|
||||
|
||||
[ "IN: temporary : bar ( x -- y ) 2 + ;\n" ]
|
||||
[ [ \ bar see ] string-out ] unit-test
|
||||
|
||||
[ "( a b -- c d )" ] [
|
||||
{ "a" "b" } { "c" "d" } <effect> effect>string
|
||||
|
|
@ -58,6 +49,26 @@ unit-test
|
|||
{ } { } <effect> effect>string
|
||||
] unit-test
|
||||
|
||||
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
|
||||
|
||||
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
|
||||
|
||||
[ "[ 1 2 DUP ]" ]
|
||||
[
|
||||
[ 1 2 dup ] dup hilite-quotation set 2 hilite-index set
|
||||
[ pprint ] string-out
|
||||
] unit-test
|
||||
|
||||
: foo ( a -- b ) dup * ; inline
|
||||
|
||||
[ "IN: temporary : foo ( a -- b ) dup * ; inline\n" ]
|
||||
[ [ \ foo see ] string-out ] unit-test
|
||||
|
||||
: bar ( x -- y ) 2 + ;
|
||||
|
||||
[ "IN: temporary : bar ( x -- y ) 2 + ;\n" ]
|
||||
[ [ \ bar see ] string-out ] unit-test
|
||||
|
||||
[ ] [ \ fixnum see ] unit-test
|
||||
|
||||
[ ] [ \ integer see ] unit-test
|
||||
|
|
@ -67,21 +78,3 @@ unit-test
|
|||
[ ] [ \ compound see ] unit-test
|
||||
|
||||
[ ] [ \ duplex-stream see ] unit-test
|
||||
|
||||
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
|
||||
|
||||
TUPLE: cat gender declawed? castrated? ;
|
||||
|
||||
[ "T{ cat \n f \"m\" \n t f\n}" ]
|
||||
[
|
||||
[
|
||||
10 margin set
|
||||
T{ cat f "m" t f } unparse
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ "[ 1 2 DUP ]" ]
|
||||
[
|
||||
[ 1 2 dup ] dup hilite-quotation set 2 hilite-index set
|
||||
[ pprint ] string-out
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: definitions
|
||||
USING: arrays errors generic hashtables io kernel math
|
||||
namespaces parser prettyprint sequences styles words ;
|
||||
namespaces parser prettyprint prettyprint-internals sequences
|
||||
styles words ;
|
||||
|
||||
: where ( defspec -- loc )
|
||||
where* dup [ first2 >r ?resource-path r> 2array ] when ;
|
||||
|
|
@ -33,7 +34,7 @@ GENERIC: synopsis* ( defspec -- )
|
|||
|
||||
: in. ( word -- )
|
||||
word-vocabulary [
|
||||
H{ } <block \ IN: pprint-word write-vocab block;
|
||||
H{ } clone <flow \ IN: pprint-word write-vocab block>
|
||||
] when* ;
|
||||
|
||||
: comment. ( string -- )
|
||||
|
|
@ -83,9 +84,9 @@ M: word declarations.
|
|||
[
|
||||
dup synopsis*
|
||||
dup definition [
|
||||
H{ } <block
|
||||
H{ } <defblock
|
||||
pprint-elements pprint-; declarations.
|
||||
block;
|
||||
block>
|
||||
] [
|
||||
2drop
|
||||
] if newline
|
||||
|
|
@ -104,9 +105,9 @@ M: predicate see-class*
|
|||
\ PREDICATE: pprint-word
|
||||
dup superclass pprint-word
|
||||
dup pprint-word
|
||||
H{ } <block
|
||||
H{ } <defblock
|
||||
"definition" word-prop pprint-elements
|
||||
pprint-; block; ;
|
||||
pprint-; block> ;
|
||||
|
||||
M: tuple-class see-class*
|
||||
\ TUPLE: pprint-word
|
||||
|
|
@ -117,9 +118,12 @@ M: tuple-class see-class*
|
|||
M: word see-class* drop ;
|
||||
|
||||
: see-class ( word -- )
|
||||
[
|
||||
dup class?
|
||||
[ see-class* newline ] [ drop ] if
|
||||
] with-pprint ;
|
||||
dup class? [
|
||||
terpri [ see-class* ] with-pprint terpri
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: see-subdefs ( word -- ) subdefs [ terpri see ] each ;
|
||||
|
||||
M: word see dup (see) dup see-class see-subdefs ;
|
||||
|
|
|
|||
|
|
@ -1,23 +0,0 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: prettyprint
|
||||
USING: generic kernel namespaces prettyprint sequences strings
|
||||
styles words ;
|
||||
|
||||
GENERIC: summary ( object -- string )
|
||||
|
||||
M: object summary
|
||||
"an instance of the " swap class word-name " class" append3 ;
|
||||
|
||||
M: input summary
|
||||
"Input: " swap input-string dup string?
|
||||
[ "\n" split1 "..." "" ? append ] [ unparse-short ] if
|
||||
append ;
|
||||
|
||||
M: vocab-link summary
|
||||
[
|
||||
vocab-link-name dup %
|
||||
" vocabulary (" %
|
||||
words length #
|
||||
" words)" %
|
||||
] "" make ;
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
IN: prettyprint
|
||||
USING: help ;
|
||||
|
||||
HELP: summary
|
||||
{ $values { "object" "an object" } { "string" "a string" } }
|
||||
{ $contract "Outputs a brief description of the object." } ;
|
||||
Loading…
Reference in New Issue