diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 036a154841..ea6d49ad6d 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -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: diff --git a/doc/handbook/prettyprinter.facts b/doc/handbook/prettyprinter.facts index ca3254e9d9..080992e69b 100644 --- a/doc/handbook/prettyprinter.facts +++ b/doc/handbook/prettyprinter.facts @@ -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 } -{ $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." ; diff --git a/library/definitions.factor b/library/definitions.factor index 9b7ec46c6c..c12bafa6ef 100644 --- a/library/definitions.factor +++ b/library/definitions.factor @@ -9,6 +9,4 @@ GENERIC: where* ( defspec -- loc ) GENERIC: subdefs ( defspec -- seq ) -: see-subdefs ( word -- ) subdefs [ see ] each ; - GENERIC: forget ( defspec -- ) diff --git a/library/help/topics.factor b/library/help/topics.factor index 9beea543f9..c78968b5fd 100644 --- a/library/help/topics.factor +++ b/library/help/topics.factor @@ -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 diff --git a/library/load.factor b/library/load.factor index 978793172d..3aa49a0f13 100644 --- a/library/load.factor +++ b/library/load.factor @@ -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" diff --git a/library/prettyprint/backend.factor b/library/prettyprint/backend.factor new file mode 100644 index 0000000000..d03b9c30d2 --- /dev/null +++ b/library/prettyprint/backend.factor @@ -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 + ] [ + 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{ } [ pprint-word ] when* block> + ] check-recursion ; diff --git a/library/prettyprint/backend.facts b/library/prettyprint/backend.facts new file mode 100644 index 0000000000..3689ac9f24 --- /dev/null +++ b/library/prettyprint/backend.facts @@ -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 } ; + +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 ; diff --git a/library/prettyprint/core.factor b/library/prettyprint/core.factor new file mode 100644 index 0000000000..7a4cdcc13e --- /dev/null +++ b/library/prettyprint/core.factor @@ -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 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 diff --git a/library/prettyprint/core.facts b/library/prettyprint/core.facts new file mode 100644 index 0000000000..1c053bb591 --- /dev/null +++ b/library/prettyprint/core.facts @@ -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." } ; diff --git a/library/prettyprint/frontend.factor b/library/prettyprint/frontend.factor new file mode 100644 index 0000000000..9a1b89fabd --- /dev/null +++ b/library/prettyprint/frontend.factor @@ -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{ } 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 ; diff --git a/library/prettyprint/frontend.facts b/library/prettyprint/frontend.facts new file mode 100644 index 0000000000..8d037dd5e8 --- /dev/null +++ b/library/prettyprint/frontend.facts @@ -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." } ; diff --git a/library/prettyprint/sections.factor b/library/prettyprint/sections.factor new file mode 100644 index 0000000000..b616a0a601 --- /dev/null +++ b/library/prettyprint/sections.factor @@ -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
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 ; + +: ( ] change ; + +: style> stdio [ delegate ] change ; + +: change-indent ( n -- ) + tab-size get * indent [ + ] change ; + +: ( block -- ) -1 change-indent ; + +! Text section +TUPLE: text string ; + +C: text ( string style -- text ) + [ >r over length 1+
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 -- ) add-section ; + +: text ( string -- ) H{ } styled-text ; + +! Newline section +TUPLE: newline ; + +C: newline ( -- section ) + H{ } 0
over set-delegate ; + +M: newline block-empty? drop f ; + +M: newline section-fits? drop t ; + +M: newline short-section section-start fresh-line ; + +: newline ( -- ) add-section ; + +! Inset section +TUPLE: inset ; + +C: inset ( style -- block ) + swap 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