From b040d4d033442061d640c2866e90d53c55315a5f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 04:33:35 -0500
Subject: [PATCH] Convert prettyprinter to inheritance
---
core/classes/tuple/tuple-docs.factor | 2 +-
core/prettyprint/prettyprint-docs.factor | 6 +-
.../prettyprint/sections/sections-docs.factor | 14 +--
core/prettyprint/sections/sections.factor | 118 +++++++++---------
4 files changed, 70 insertions(+), 70 deletions(-)
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 0abfb8851f..3e1f85c936 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -269,7 +269,7 @@ $low-level-note ;
HELP: tuple-slots
{ $values { "tuple" tuple } { "seq" sequence } }
-{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
+{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
{ tuple-slots tuple>array } related-words
diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor
index 7ea0f5c412..2b294115be 100755
--- a/core/prettyprint/prettyprint-docs.factor
+++ b/core/prettyprint/prettyprint-docs.factor
@@ -48,7 +48,7 @@ ARTICLE: "prettyprint-limitations" "Prettyprinter limitations"
"On a final note, the " { $link short. } " and " { $link pprint-short } " words restrict the length and nesting of printed sequences, their output will very likely not be valid syntax. They are only intended for interactive use." ;
ARTICLE: "prettyprint-section-protocol" "Prettyprinter section protocol"
-"Prettyprinter sections must delegate to an instance of " { $link section } ", and they must also obey a protocol."
+"Prettyprinter sections must subclass " { $link section } ", and they must also obey a protocol."
$nl
"Layout queries:"
{ $subsection section-fits? }
@@ -60,8 +60,8 @@ $nl
{ $subsection short-section }
{ $subsection long-section }
"Utilities to use when implementing sections:"
-{ $subsection <section> }
-{ $subsection delegate>block }
+{ $subsection construct-section }
+{ $subsection construct-block }
{ $subsection add-section } ;
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index 9833a7e50a..e704df2085 100755
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -67,7 +67,7 @@ HELP: short-section?
{ $contract "Tests if a section should be output as a " { $link short-section } ". The default implementation calls " { $link section-fits? } " but this behavior can be cutomized." } ;
HELP: section
-{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various classes which delegate to this class:"
+{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various subclasses of this class:"
{ $list
{ $link text }
{ $link line-break }
@@ -78,12 +78,12 @@ HELP: section
}
"Instances of this class have the following slots:"
{ $list
- { { $link section-start } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-end } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-start-group? } " - see " { $link start-group } }
- { { $link section-end } " - see " { $link end-group } }
- { { $link section-style } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
- { { $link section-overhang } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
+ { { $snippet "start" } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "end" } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "start-group?" } " - see " { $link start-group } }
+ { { $snippet "end-group?" } " - see " { $link end-group } }
+ { { $snippet "style" } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
+ { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
HELP: <section>
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index 9574d18eb1..c5b26ca837 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested ;
+io.streams.nested accessors ;
IN: prettyprint.sections
! State
@@ -70,17 +70,15 @@ start end
start-group? end-group?
style overhang ;
-: <section> ( style length -- section )
- position [ dup rot + dup ] change 0 {
- set-section-style
- set-section-start
- set-section-end
- set-section-overhang
- } section construct ;
+: construct-section ( length class -- section )
+ construct-empty
+ position get >>start
+ swap position [ + ] change
+ position get >>end
+ 0 >>overhang ; inline
M: section section-fits? ( section -- ? )
- dup section-end last-newline get -
- swap section-overhang + text-fits? ;
+ [ end>> last-newline get - ] [ overhang>> ] bi + text-fits? ;
M: section indent-section? drop f ;
@@ -98,10 +96,10 @@ M: object short-section? section-fits? ;
: indent> ( section -- ) tab-size get neg change-indent ;
: <fresh-line ( section -- )
- section-start fresh-line ;
+ start>> fresh-line ;
: fresh-line> ( section -- )
- dup newline-after? [ section-end fresh-line ] [ drop ] if ;
+ dup newline-after? [ end>> fresh-line ] [ drop ] if ;
: <long-section ( section -- )
dup unindent-first-line?
@@ -124,53 +122,54 @@ M: object short-section? section-fits? ;
] if ;
! Break section
-TUPLE: line-break type ;
+TUPLE: line-break < section type ;
: <line-break> ( type -- section )
- H{ } 0 <section>
- { set-line-break-type set-delegate }
- \ line-break construct ;
+ 0 \ line-break construct-section
+ swap >>type ;
M: line-break short-section drop ;
M: line-break long-section drop ;
! Block sections
-TUPLE: block sections ;
+TUPLE: block < section sections ;
+
+: construct-block ( style class -- block )
+ 0 swap construct-section
+ V{ } clone >>sections
+ swap >>style ; inline
: <block> ( style -- block )
- 0 <section> V{ } clone
- { set-delegate set-block-sections } block construct ;
-
-: delegate>block ( obj -- ) H{ } <block> swap set-delegate ;
+ block construct-block ;
: pprinter-block ( -- block ) pprinter-stack get peek ;
: add-section ( section -- )
- pprinter-block block-sections push ;
+ pprinter-block sections>> push ;
: last-section ( -- section )
- pprinter-block block-sections
+ pprinter-block sections>>
[ line-break? not ] find-last nip ;
: start-group ( -- )
- t last-section set-section-start-group? ;
+ last-section t >>start-group? drop ;
: end-group ( -- )
- t last-section set-section-end-group? ;
+ last-section t >>end-group? drop ;
: advance ( section -- )
- dup section-start last-newline get = not
- swap short-section? and
- [ bl ] when ;
+ [ start>> last-newline get = not ]
+ [ short-section? ] bi
+ and [ bl ] when ;
: line-break ( type -- ) [ <line-break> add-section ] when* ;
M: block section-fits? ( section -- ? )
- line-limit? [ drop t ] [ delegate section-fits? ] if ;
+ line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap block-sections [ line-break? not ] subset
+ swap sections>> [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
] with each ; inline
@@ -179,28 +178,28 @@ M: block short-section ( block -- )
[ advance ] pprint-sections ;
: do-break ( break -- )
- dup line-break-type hard eq?
+ dup type>> hard eq?
over section-end last-newline get - margin get 2/ > or
[ <fresh-line ] [ drop ] if ;
-: empty-block? ( block -- ? ) block-sections empty? ;
+: empty-block? ( block -- ? ) sections>> empty? ;
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
: (<block) pprinter-stack get push ;
-: <block H{ } <block> (<block) ;
+: <block f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
! Text section
-TUPLE: text string ;
+TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ <section>
- { set-text-string set-delegate }
- \ text construct ;
+ over length 1+ \ text construct-section
+ swap >>style
+ swap >>string ;
M: text short-section text-string write ;
@@ -211,18 +210,18 @@ M: text long-section short-section ;
: text ( string -- ) H{ } styled-text ;
! Inset section
-TUPLE: inset narrow? ;
+TUPLE: inset < block narrow? ;
: <inset> ( narrow? -- block )
- 2 H{ } <block>
- { set-inset-narrow? set-section-overhang set-delegate }
- inset construct ;
+ H{ } inset construct-block
+ 2 >>overhang
+ swap >>narrow? ;
M: inset long-section
- dup inset-narrow? [
+ dup narrow?>> [
[ <fresh-line ] pprint-sections
] [
- delegate long-section
+ call-next-method
] if ;
M: inset indent-section? drop t ;
@@ -232,25 +231,26 @@ M: inset newline-after? drop t ;
: <inset ( narrow? -- ) <inset> (<block) ;
! Flow section
-TUPLE: flow ;
+TUPLE: flow < block ;
: <flow> ( -- block )
- H{ } <block> flow construct-delegate ;
+ H{ } flow construct-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
#! a newline, do it; otherwise, don't bother, print it as
#! a short section
- dup section-fits?
- over section-end rot section-start - text-fits? not or ;
+ [ section-fits? ]
+ [ [ end>> ] [ start>> ] bi - text-fits? not ] bi
+ or ;
: <flow ( -- ) <flow> (<block) ;
! Colon definition section
-TUPLE: colon ;
+TUPLE: colon < block ;
: <colon> ( -- block )
- H{ } <block> colon construct-delegate ;
+ H{ } colon construct-block ;
M: colon long-section short-section ;
@@ -261,11 +261,11 @@ M: colon unindent-first-line? drop t ;
: <colon ( -- ) <colon> (<block) ;
: save-end-position ( block -- )
- position get swap set-section-end ;
+ position get >>end drop ;
: block> ( -- )
pprinter-stack get pop
- [ dup save-end-position add-section ] if-nonempty ;
+ [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
: with-section-state ( quot -- )
[
@@ -278,7 +278,7 @@ M: colon unindent-first-line? drop t ;
: do-pprint ( block -- )
[
[
- dup section-style [
+ dup style>> [
[ end-printing set dup short-section ] callcc0
] with-nesting drop
] if-nonempty
@@ -298,9 +298,9 @@ M: f section-start-group? drop t ;
M: f section-end-group? drop f ;
: split-before ( section -- )
- dup section-start-group? prev get section-end-group? and
- swap flow? prev get flow? not and
- or split-groups ;
+ [ section-start-group? prev get section-end-group? and ]
+ [ flow? prev get flow? not and ]
+ bi or split-groups ;
: split-after ( section -- )
section-end-group? split-groups ;
@@ -315,19 +315,19 @@ M: f section-end-group? drop f ;
] { } make { t } split [ empty? not ] subset ;
: break-group? ( seq -- ? )
- dup first section-fits? swap peek section-fits? not and ;
+ [ first section-fits? ] [ peek section-fits? not ] bi and ;
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
M: block long-section ( block -- )
[
- block-sections chop-break group-flow [
+ sections>> chop-break group-flow [
dup ?break-group [
dup line-break? [
do-break
] [
- dup advance pprint-section
+ [ advance ] [ pprint-section ] bi
] if
] each
] each