- reader syntax for arrays, byte arrays, displaced aliens\r
- fix infer hang\r
- out of memory error when printing global namespace\r
-- HTML prettyprinting\r
\r
+ ui:\r
\r
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: html
+USING: prettyprint ;
USE: strings
USE: lists
USE: kernel
: attrs>string ( alist -- string )
#! Convert the attrs alist to a string
#! suitable for embedding in an html tag.
- reverse [
- [ dup car % "='" % cdr % "'" % ] each
- ] "" make ;
+ [ [ dup car % "='" % cdr % "'" % ] "" make ] map " " join ;
: write-attributes ( n: namespace -- )
#! With the attribute namespace on the stack, get the attributes
#! and write them to standard output. If no attributes exist, write
#! nothing.
- "attrs" get [ " " write attrs>string write ] when* ;
+ "attrs" get attrs>string write ;
: store-prev-attribute ( n: tag value -- )
#! Assumes an attribute namespace is on the stack.
#! and sets it's value to the current value on the stack.
#! If there is no previous attribute, no value is expected
#! on the stack.
- "current-attribute" get [ swons "attrs" [ cons ] change ] when* ;
+ "current-attribute" get [ swons "attrs" get push ] when* ;
-! HTML tag words
-!
-! Each closable HTML tag has four words defined. The example below is for
-! <p>:
-!
-! : <p> ( -- )
-! #! Writes the opening tag to standard output.
-! "<p>" write ;
-
-! : <p ( -- n: <namespace> )
-! #! Used for setting inline attributes. Prints out
-! #! an unclosed opening tag.
-! "<p" write {{ }} clone >n ;
-!
-! : p> ( n: <namespace> -- )
-! #! Used to close off inline attribute version of word.
-! #! Prints out attributes and closes opening tag.
-! store-prev-attribute write-attributes n> drop ">" write ;
-!
-! : </p> ( -- )
-! #! Write out the closing tag.
-! "</foo>" write ;
-!
-! Each open only HTML tag has only three words:
-!
-! : <input/> ( -- )
-! #! Used for printing the tag with no attributes.
-! "<input>" write ;
-!
-! : <input ( -- n: <namespace> )
-! #! Used for setting inline attributes.
-! "<input" write {{ }} clone >n ;
-!
-! : input/> ( n: <namespace> -- )
-! #! Used to close off inline attribute version of word
-! #! and print the tag/
-! store-prev-attribute write-attributes n> drop ">" write ;
-!
-! Each attribute word has the form xxxx= where 'xxxx' is the attribute
-! name. The example below is for href:
-!
-! : href= ( n: <namespace> optional-value -- )
-! store-prev-attribute "href" "current-attribute" set ;
-
-: create-word ( vocab name def -- )
+: html-word ( name def -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
- >r swap create r> define-compound ;
+ >r "html" create dup r> define-compound ;
-: def-for-html-word-<foo> ( name -- name quot )
+: <foo> "<" swap ">" append3 ;
+
+: do-<foo> <foo> write ;
+
+: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
- "<" swap ">" append3 dup [ write ] cons ;
+ dup <foo> swap [ do-<foo> ] cons html-word define-open ;
+
+: <foo "<" swap append ;
+
+: do-<foo write {{ }} clone >n { } clone "attrs" set ;
-: def-for-html-word-<foo ( name -- name quot )
+: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
- "<" swap append dup [ write {{ }} clone >n ] cons ;
+ <foo dup [ do-<foo ] cons html-word drop ;
-: def-for-html-word-foo> ( name -- name quot )
+: foo> ">" append ;
+
+: do-foo> store-prev-attribute write-attributes n> drop ">" write ;
+
+: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
#! word.
- ">" append [
- store-prev-attribute write-attributes n> drop ">" write
- ] ;
+ foo> [ do-foo> ] html-word define-open ;
+
+: </foo> [ "</" % % ">" % ] "" make ;
-: def-for-html-word-</foo> ( name -- name quot )
+: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
- [ "</" % % ">" % ] "" make dup [ write ] cons ;
+ </foo> dup [ write ] cons html-word define-close ;
-: def-for-html-word-<foo/> ( name -- name quot )
+: <foo/> [ "<" % % "/>" % ] "" make ;
+
+: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
- [ "<" % dup % "/>" % ] "" make swap
- [ "<" % % ">" % ] "" make
- [ write ] cons ;
+ dup <foo/> swap [ do-<foo> ] cons html-word drop ;
+
+: foo/> "/>" append ;
-: def-for-html-word-foo/> ( name -- name quot )
+: def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned
#! word.
- "/>" append [
- store-prev-attribute write-attributes n> drop ">" write
- ] ;
+ foo/> [ do-foo> ] html-word define-close ;
: define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for
#! that closable HTML tag.
- "html" swap
- 2dup def-for-html-word-<foo> create-word
- 2dup def-for-html-word-<foo create-word
- 2dup def-for-html-word-foo> create-word
- def-for-html-word-</foo> create-word ;
+ dup def-for-html-word-<foo>
+ dup def-for-html-word-<foo
+ dup def-for-html-word-foo>
+ def-for-html-word-</foo> ;
: define-open-html-word ( name -- )
#! Given an HTML tag name, define the words for
#! that open HTML tag.
- "html" swap
- 2dup def-for-html-word-<foo/> create-word
- 2dup def-for-html-word-<foo create-word
- def-for-html-word-foo/> create-word ;
+ dup def-for-html-word-<foo/>
+ dup def-for-html-word-<foo
+ def-for-html-word-foo/> ;
: define-attribute-word ( name -- )
- "html" swap dup "=" append swap
- [ store-prev-attribute ] cons reverse
- [ "current-attribute" set ] append create-word ;
+ dup "=" append swap [
+ \ store-prev-attribute , , [ "current-attribute" set ] %
+ ] [ ] make html-word drop ;
! Define some closed HTML tags
[
: lcm ( a b -- c )
#! Smallest integer such that c/a and c/b are both integers.
- 2dup gcd nip >r * r> /i ;
+ 2dup gcd nip >r * r> /i ; foldable
: mod-inv ( x n -- y )
#! Compute the multiplicative inverse of x mod n.
- gcd 1 = [ "Non-trivial divisor found" throw ] unless ; foldable
-
-: bitroll ( n s w -- n )
- #! Roll n by s bits to the right, wrapping around after
- #! w bits.
- [ mod shift ] 3keep over 0 >= [ - ] [ + ] ifte shift bitor ;
+ gcd 1 = [ "Non-trivial divisor found" throw ] unless ;
foldable
IN: math-internals
: fraction> ( a b -- a/b )
- dup 1 number= [
- drop
- ] [
- (fraction>)
- ] ifte ; inline
+ dup 1 number= [ drop ] [ (fraction>) ] ifte ; inline
: division-by-zero ( x y -- )
"Division by zero" throw drop ; inline
! State
SYMBOL: column
SYMBOL: indent
-SYMBOL: last-newline?
SYMBOL: last-newline
SYMBOL: recursion-check
SYMBOL: line-count
SYMBOL: end-printing
+SYMBOL: newline-ok?
! Configuration
SYMBOL: tab-size
recursion-check off
0 column set
0 indent set
- last-newline? off
0 last-newline set
0 line-count set
string-limit off
+ newline-ok? off
] bind
TUPLE: pprinter stack ;
: section-fits? ( section -- ? )
section-end last-newline get - indent get + margin get <= ;
+: insert-newline? ( section -- ? )
+ section-fits? not newline-ok? and ;
+
: line-limit? ( -- ? )
line-limit get dup [ line-count get <= ] when ;
: do-indent indent get CHAR: \s fill write ;
: fresh-line ( n -- )
+ #! n is current column position.
last-newline set
line-count inc
line-limit? [ " ..." write end-printing get call ] when
TUPLE: text string style ;
C: text ( string style -- section )
- pick length <section> over set-delegate
+ pick length 1 + <section> over set-delegate
[ set-text-style ] keep
[ set-text-string ] keep ;
M: text pprint-section*
- dup text-string swap text-style format ;
+ dup text-string swap text-style format " " write ;
TUPLE: block sections ;
pprinter-block block-sections push
] ifte ;
-: text ( string style -- )
- <text> pprinter get add-section ;
-
-: bl ( -- ) " " f text ;
+: text ( string style -- ) <text> pprinter get add-section ;
: <indent ( section -- ) section-indent indent [ + ] change ;
dup section-nl-after?
[ section-end fresh-line ] [ drop ] ifte ;
-: advance ( section -- )
- section-start last-newline get =
- [ last-newline inc ] [ " " write ] ifte ;
-
: pprint-section ( section -- )
- last-newline? get [
- last-newline? off dup section-fits? [
- dup advance pprint-section*
- ] [
- inset-section
- ] ifte
- ] [
- pprint-section*
- ] ifte ;
+ dup insert-newline? newline-ok? on
+ [ inset-section ] [ pprint-section* ] ifte ;
-TUPLE: newline forced? ;
+TUPLE: newline ;
-C: newline ( forced -- section )
- 1 <section> over set-delegate
- [ set-newline-forced? ] keep ;
+C: newline ( -- section )
+ 0 <section> over set-delegate ;
-M: newline pprint-section*
- dup newline-forced?
- [ section-start fresh-line ] [ drop last-newline? on ] ifte ;
+M: newline pprint-section* ( newline -- )
+ section-start fresh-line newline-ok? off ;
M: block pprint-section* ( block -- )
block-sections [ pprint-section ] each ;
: <block ( -- ) <block> pprinter get pprinter-stack push ;
-: newline ( forced -- ) <newline> pprinter get add-section ;
+: newline ( -- ) <newline> pprinter get add-section ;
: end-block ( block -- ) column get swap set-section-end ;
: pop-block ( pprinter -- ) pprinter-stack pop drop ;
-: block> ( -- )
+: (block>) ( -- )
pprinter get dup pprinter-block
dup end-block swap dup pop-block add-section ;
+: last-block? ( -- ? )
+ pprinter get pprinter-stack length 1 = ;
+
+: block> ( -- )
+ #! Protect against malformed <block ... block> forms.
+ last-block? [ (block>) ] unless ;
+
: block; ( -- )
pprinter get pprinter-block f swap set-section-nl-after?
block> ;
+: end-blocks ( -- ) last-block? [ (block>) end-blocks ] unless ;
+
C: pprinter ( -- stream )
<block> 1vector over set-pprinter-stack ;
[
end-printing set
dup pprinter-block pprint-section
+ end-blocks
] callcc0 drop ;
GENERIC: pprint* ( obj -- )
"( unprintable object: " swap class word-name " )" append3
f text ;
-M: real pprint* ( obj -- )
- number>string f text ;
-
-M: complex pprint* ( num -- )
- \ #{ pprint-word bl
- dup real pprint* bl imaginary pprint* bl
- \ }# pprint-word ;
+M: real pprint* ( obj -- ) number>string f text ;
: ch>ascii-escape ( ch -- esc )
{{
M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
M: word pprint* ( word -- )
- dup parsing? [ \ POSTPONE: pprint-word bl ] when pprint-word ;
+ dup "pprint-before-hook" word-prop call
+ dup pprint-word
+ "pprint-after-hook" word-prop call ;
M: t pprint* drop "t" f text ;
[ swap 2dup length < [ head t ] [ nip f ] ifte ]
[ drop f ] ifte ;
+: pprint-element ( object -- )
+ dup parsing? [ \ POSTPONE: pprint-word ] when pprint* ;
+
: pprint-elements ( seq -- )
length-limit? >r
- [ pprint* f newline ] each
+ [ pprint-element ] each
r> [ "... " f text ] when ;
: pprint-sequence ( seq start end -- )
- swap pprint-word f newline <block
- swap pprint-elements block> pprint-word ;
+ swap pprint* swap pprint-elements pprint* ;
+
+M: complex pprint* ( num -- )
+ >rect 2vector \ #{ \ }# pprint-sequence ;
M: cons pprint* ( list -- )
[
dup expired? [
drop "( alien expired )"
] [
- \ ALIEN: pprint-word bl alien-address number>string
+ \ ALIEN: pprint-word alien-address number>string
] ifte f text ;
M: wrapper pprint* ( wrapper -- )
dup wrapped word? [
- \ \ pprint-word bl wrapped pprint-word
+ \ \ pprint-word wrapped pprint-word
] [
wrapped 1vector \ W[ \ ]W pprint-sequence
] ifte ;
: sequence. ( sequence -- ) [ short. ] each ;
-: stack. reverse-slice sequence. ;
+: stack. ( sequence -- ) reverse-slice sequence. ;
: .s datastack stack. ;
: .r callstack stack. ;
: .b >bin print ;
: .o >oct print ;
: .h >hex print ;
+
+: define-close ( word -- )
+ #! The word will be pretty-printed as a block closer.
+ #! Examples are ] } }} ]] and so on.
+ [ block> ] "pprint-before-hook" set-word-prop ;
+
+: define-open
+ #! The word will be pretty-printed as a block opener.
+ #! Examples are [ { {{ << and so on.
+ [ <block ] "pprint-after-hook" set-word-prop ;
+
+{
+ { POSTPONE: [ POSTPONE: ] }
+ { POSTPONE: { POSTPONE: } }
+ { POSTPONE: {{ POSTPONE: }} }
+ { POSTPONE: [[ POSTPONE: ]] }
+ { POSTPONE: [[ POSTPONE: ]] }
+ { POSTPONE: << POSTPONE: >> }
+} [ 2unseq define-close define-open ] each
styles words ;
: declaration. ( word prop -- )
- tuck word-name word-prop [ bl pprint-word ] [ drop ] ifte ;
+ tuck word-name word-prop [ pprint-word ] [ drop ] ifte ;
: declarations. ( word -- )
[
] ?ifte ;
: stack-effect. ( string -- )
- [ bl "(" swap ")" append3 comment. ] when* ;
+ [ "(" swap ")" append3 comment. ] when* ;
: in. ( word -- )
- <block \ IN: pprint-word bl word-vocabulary f text block;
- t newline ;
+ <block \ IN: pprint-word word-vocabulary f text block;
+ newline ;
: definer. ( word -- )
- dup definer pprint-word bl
+ dup definer pprint-word
dup pprint-word
- stack-effect stack-effect.
- f newline ;
+ stack-effect stack-effect. ;
GENERIC: (see) ( word -- )
-M: word (see) definer. t newline ;
+M: word (see) definer. newline ;
: documentation. ( word -- )
"documentation" word-prop [
- "\n" split [ "#!" swap append comment. t newline ] each
+ "\n" split [ "#!" swap append comment. newline ] each
] when* ;
: pprint-; \ ; pprint-word ;
pprint-; declarations. block; ;
M: compound (see)
- dup word-def swap see-body t newline ;
+ dup word-def swap see-body newline ;
: method. ( word [[ class method ]] -- )
- \ M: pprint-word bl
- unswons pprint-word bl
- swap pprint-word f newline
+ \ M: pprint-word
+ unswons pprint-word
+ swap pprint-word
<block pprint-elements pprint-;
- block; t newline ;
+ block; newline ;
M: generic (see)
<block
dup dup "combination" word-prop
- swap see-body block; t newline
+ swap see-body block; newline
dup methods [ method. ] each-with ;
GENERIC: class. ( word -- )
] ifte ;
M: union class.
- \ UNION: pprint-word bl
- dup pprint-word bl
- "members" word-prop pprint-elements pprint-; t newline ;
+ \ UNION: pprint-word
+ dup pprint-word
+ "members" word-prop pprint-elements pprint-; newline ;
M: complement class.
- \ COMPLEMENT: pprint-word bl
- dup pprint-word bl
- "complement" word-prop pprint-word t newline ;
+ \ COMPLEMENT: pprint-word
+ dup pprint-word
+ "complement" word-prop pprint-word newline ;
M: predicate class.
- \ PREDICATE: pprint-word bl
- dup "superclass" word-prop pprint-word bl
- dup pprint-word f newline
+ \ PREDICATE: pprint-word
+ dup "superclass" word-prop pprint-word
+ dup pprint-word
<block
"definition" word-prop pprint-elements
- pprint-; block; t newline ;
+ pprint-; block; newline ;
M: tuple-class class.
- \ TUPLE: pprint-word bl
- dup pprint-word bl
- "slot-names" word-prop [ f text bl ] each
- pprint-; t newline ;
+ \ TUPLE: pprint-word
+ dup pprint-word
+ "slot-names" word-prop [ f text ] each
+ pprint-; newline ;
M: word class. drop ;
: find-slider [ slider? ] find-parent ;
+: thumb-min { 12 12 0 } ;
+
: slider-scale ( slider -- n )
#! A scaling factor such that if x is a slider co-ordinate,
#! x*n is the screen position of the thumb, and conversely
: thumb-dim ( slider -- h )
dup slider-page swap slider>screen ;
-: thumb-min { 12 12 0 } ;
-
: layout-thumb ( slider -- )
dup thumb-loc over slider-vector n*v
over slider-thumb set-rect-loc
projects / factor.git / commitdiff