remove old accessors, cleanup
Doug Coleman
parent
a3e25491c0
commit
8f00739601
|
|
@ -56,8 +56,7 @@ TUPLE: link attributes clickable ;
|
|||
: trim-text ( vector -- vector' )
|
||||
[
|
||||
dup name>> text = [
|
||||
[ text>> [ blank? ] trim ] keep
|
||||
[ set-tag-text ] keep
|
||||
[ [ blank? ] trim ] change-text
|
||||
] when
|
||||
] map ;
|
||||
|
||||
|
|
@ -173,8 +172,7 @@ TUPLE: link attributes clickable ;
|
|||
[
|
||||
{
|
||||
{ [ dup name>> "form" = ]
|
||||
[ "form action: " write attributes>> "action" swap at print
|
||||
] }
|
||||
[ "form action: " write attributes>> "action" swap at print ] }
|
||||
{ [ dup name>> "input" = ] [ input. ] }
|
||||
[ drop ]
|
||||
} cond
|
||||
|
|
|
|||
|
|
@ -2,19 +2,19 @@ USING: html.parser kernel tools.test ;
|
|||
IN: html.parser.tests
|
||||
|
||||
[
|
||||
V{ T{ tag f "html" H{ } f f f } }
|
||||
V{ T{ tag f "html" H{ } f f } }
|
||||
] [ "<html>" parse-html ] unit-test
|
||||
|
||||
[
|
||||
V{ T{ tag f "html" H{ } f f t } }
|
||||
V{ T{ tag f "html" H{ } f t } }
|
||||
] [ "</html>" parse-html ] unit-test
|
||||
|
||||
[
|
||||
V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f f } }
|
||||
V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
|
||||
] [ "<a href=\"http://factorcode.org/\">" parse-html ] unit-test
|
||||
|
||||
[
|
||||
V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f f } }
|
||||
V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
|
||||
] [ "<a href = \"http://factorcode.org/\" >" parse-html ] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -26,7 +26,6 @@ V{
|
|||
H{ { "baz" "\"quux\"" } { "foo" "bar's" } }
|
||||
f
|
||||
f
|
||||
f
|
||||
}
|
||||
}
|
||||
] [ "<a foo=\"bar's\" baz='\"quux\"' >" parse-html ] unit-test
|
||||
|
|
@ -39,25 +38,25 @@ V{
|
|||
{ "foo" "bar" }
|
||||
{ "href" "http://factorcode.org/" }
|
||||
{ "baz" "quux" }
|
||||
} f f f }
|
||||
} f f }
|
||||
}
|
||||
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ tag f "html" H{ } f f f }
|
||||
T{ tag f "head" H{ } f f f }
|
||||
T{ tag f "head" H{ } f f t }
|
||||
T{ tag f "html" H{ } f f t }
|
||||
T{ tag f "html" H{ } f f }
|
||||
T{ tag f "head" H{ } f f }
|
||||
T{ tag f "head" H{ } f t }
|
||||
T{ tag f "html" H{ } f t }
|
||||
}
|
||||
] [ "<html<head</head</html" parse-html ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ tag f "head" H{ } f f f }
|
||||
T{ tag f "title" H{ } f f f }
|
||||
T{ tag f text f "Spagna" f f }
|
||||
T{ tag f "title" H{ } f f t }
|
||||
T{ tag f "head" H{ } f f t }
|
||||
T{ tag f "head" H{ } f f }
|
||||
T{ tag f "title" H{ } f f }
|
||||
T{ tag f text f "Spagna" f }
|
||||
T{ tag f "title" H{ } f t }
|
||||
T{ tag f "head" H{ } f t }
|
||||
}
|
||||
] [ "<head<title>Spagna</title></head" parse-html ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,26 +1,22 @@
|
|||
USING: accessors arrays html.parser.utils hashtables io kernel
|
||||
namespaces prettyprint quotations
|
||||
sequences splitting state-parser strings unicode.categories unicode.case ;
|
||||
sequences splitting state-parser strings unicode.categories unicode.case
|
||||
sequences.lib ;
|
||||
IN: html.parser
|
||||
|
||||
TUPLE: tag name attributes text matched? closing? ;
|
||||
TUPLE: tag name attributes text closing? ;
|
||||
|
||||
SYMBOL: text
|
||||
SYMBOL: dtd
|
||||
SYMBOL: comment
|
||||
SYMBOL: javascript
|
||||
SINGLETON: text
|
||||
SINGLETON: dtd
|
||||
SINGLETON: comment
|
||||
SYMBOL: tagstack
|
||||
|
||||
: push-tag ( tag -- )
|
||||
tagstack get push ;
|
||||
|
||||
: closing-tag? ( string -- ? )
|
||||
dup empty? [
|
||||
drop f
|
||||
] [
|
||||
dup first CHAR: / =
|
||||
swap peek CHAR: / = or
|
||||
] if ;
|
||||
[ f ]
|
||||
[ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
|
||||
|
||||
: <tag> ( name attributes closing? -- tag )
|
||||
tag new
|
||||
|
|
@ -28,56 +24,55 @@ SYMBOL: tagstack
|
|||
swap >>attributes
|
||||
swap >>name ;
|
||||
|
||||
: make-tag ( str attribs -- tag )
|
||||
: make-tag ( string attribs -- tag )
|
||||
>r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
|
||||
|
||||
: make-text-tag ( str -- tag )
|
||||
T{ tag f text } clone [ set-tag-text ] keep ;
|
||||
: make-text-tag ( string -- tag )
|
||||
tag new
|
||||
text >>name
|
||||
swap >>text ;
|
||||
|
||||
: make-comment-tag ( str -- tag )
|
||||
T{ tag f comment } clone [ set-tag-text ] keep ;
|
||||
: make-comment-tag ( string -- tag )
|
||||
tag new
|
||||
comment >>name
|
||||
swap >>text ;
|
||||
|
||||
: make-dtd-tag ( str -- tag )
|
||||
T{ tag f dtd } clone [ set-tag-text ] keep ;
|
||||
: make-dtd-tag ( string -- tag )
|
||||
tag new
|
||||
dtd >>name
|
||||
swap >>text ;
|
||||
|
||||
: read-whitespace ( -- str )
|
||||
: read-whitespace ( -- string )
|
||||
[ get-char blank? not ] take-until ;
|
||||
|
||||
: read-whitespace* ( -- )
|
||||
read-whitespace drop ;
|
||||
: read-whitespace* ( -- ) read-whitespace drop ;
|
||||
|
||||
: read-token ( -- str )
|
||||
: read-token ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char blank? ] take-until ;
|
||||
|
||||
: read-single-quote ( -- str )
|
||||
: read-single-quote ( -- string )
|
||||
[ get-char CHAR: ' = ] take-until ;
|
||||
|
||||
: read-double-quote ( -- str )
|
||||
: read-double-quote ( -- string )
|
||||
[ get-char CHAR: " = ] take-until ;
|
||||
|
||||
: read-quote ( -- str )
|
||||
get-char next* CHAR: ' = [
|
||||
read-single-quote
|
||||
] [
|
||||
read-double-quote
|
||||
] if next* ;
|
||||
: read-quote ( -- string )
|
||||
get-char next* CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if next* ;
|
||||
|
||||
: read-key ( -- str )
|
||||
: read-key ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char CHAR: = = get-char blank? or ] take-until ;
|
||||
[ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
|
||||
|
||||
: read-= ( -- )
|
||||
read-whitespace*
|
||||
[ get-char CHAR: = = ] take-until drop next* ;
|
||||
|
||||
: read-value ( -- str )
|
||||
: read-value ( -- string )
|
||||
read-whitespace*
|
||||
get-char quote? [
|
||||
read-quote
|
||||
] [
|
||||
read-token
|
||||
] if [ blank? ] trim ;
|
||||
get-char quote? [ read-quote ] [ read-token ] if
|
||||
[ blank? ] trim ;
|
||||
|
||||
: read-comment ( -- )
|
||||
"-->" take-string* make-comment-tag push-tag ;
|
||||
|
|
@ -97,14 +92,14 @@ SYMBOL: tagstack
|
|||
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
|
||||
get-char CHAR: < = [ next* ] unless ;
|
||||
|
||||
: read-< ( -- str )
|
||||
: read-< ( -- string )
|
||||
next* get-char CHAR: ! = [
|
||||
read-bang f
|
||||
] [
|
||||
read-tag
|
||||
] if ;
|
||||
|
||||
: read-until-< ( -- str )
|
||||
: read-until-< ( -- string )
|
||||
[ get-char CHAR: < = ] take-until ;
|
||||
|
||||
: parse-text ( -- )
|
||||
|
|
@ -131,11 +126,9 @@ SYMBOL: tagstack
|
|||
] string-parse ;
|
||||
|
||||
: parse-tag ( -- )
|
||||
read-< dup empty? [
|
||||
drop
|
||||
] [
|
||||
read-< [
|
||||
(parse-tag) make-tag push-tag
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
: (parse-html) ( -- )
|
||||
get-next [
|
||||
|
|
@ -145,13 +138,7 @@ SYMBOL: tagstack
|
|||
] when ;
|
||||
|
||||
: tag-parse ( quot -- vector )
|
||||
[
|
||||
V{ } clone tagstack set
|
||||
string-parse
|
||||
] with-scope ;
|
||||
V{ } clone tagstack [ string-parse ] with-variable ;
|
||||
|
||||
: parse-html ( string -- vector )
|
||||
[
|
||||
(parse-html)
|
||||
tagstack get
|
||||
] tag-parse ;
|
||||
[ (parse-html) tagstack get ] tag-parse ;
|
||||
|
|
|
|||
|
|
@ -1,123 +1,89 @@
|
|||
USING: assocs html.parser html.parser.utils combinators
|
||||
USING: accessors assocs html.parser html.parser.utils combinators
|
||||
continuations hashtables
|
||||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
strings ;
|
||||
IN: html.parser.printer
|
||||
|
||||
SYMBOL: no-section
|
||||
SYMBOL: html
|
||||
SYMBOL: head
|
||||
SYMBOL: body
|
||||
TUPLE: state section ;
|
||||
SYMBOL: printer
|
||||
|
||||
! TUPLE: text bold? underline? strikethrough? ;
|
||||
TUPLE: html-printer ;
|
||||
TUPLE: text-printer < html-printer ;
|
||||
TUPLE: src-printer < html-printer ;
|
||||
TUPLE: html-prettyprinter < html-printer ;
|
||||
|
||||
TUPLE: text-printer ;
|
||||
TUPLE: ui-printer ;
|
||||
TUPLE: src-printer ;
|
||||
TUPLE: html-prettyprinter ;
|
||||
UNION: printer text-printer ui-printer src-printer html-prettyprinter ;
|
||||
HOOK: print-tag printer ( tag -- )
|
||||
HOOK: print-text-tag printer ( tag -- )
|
||||
HOOK: print-comment-tag printer ( tag -- )
|
||||
HOOK: print-dtd-tag printer ( tag -- )
|
||||
HOOK: print-opening-named-tag printer ( tag -- )
|
||||
HOOK: print-closing-named-tag printer ( tag -- )
|
||||
HOOK: print-text-tag html-printer ( tag -- )
|
||||
HOOK: print-comment-tag html-printer ( tag -- )
|
||||
HOOK: print-dtd-tag html-printer ( tag -- )
|
||||
HOOK: print-opening-tag html-printer ( tag -- )
|
||||
HOOK: print-closing-tag html-printer ( tag -- )
|
||||
|
||||
: print-tags ( vector -- )
|
||||
[ print-tag ] each ;
|
||||
ERROR: unknown-tag-error tag ;
|
||||
|
||||
: print-tag ( tag -- )
|
||||
{
|
||||
{ [ dup name>> text = ] [ print-text-tag ] }
|
||||
{ [ dup name>> comment = ] [ print-comment-tag ] }
|
||||
{ [ dup name>> dtd = ] [ print-dtd-tag ] }
|
||||
{ [ dup [ name>> string? ] [ closing?>> ] bi and ]
|
||||
[ print-closing-tag ] }
|
||||
{ [ dup name>> string? ]
|
||||
[ print-opening-tag ] }
|
||||
[ unknown-tag-error ]
|
||||
} cond ;
|
||||
|
||||
: print-tags ( vector -- ) [ print-tag ] each ;
|
||||
|
||||
: html-text. ( vector -- )
|
||||
[
|
||||
T{ text-printer } printer set
|
||||
print-tags
|
||||
] with-scope ;
|
||||
T{ text-printer } html-printer [ print-tags ] with-variable ;
|
||||
|
||||
: html-src. ( vector -- )
|
||||
[
|
||||
T{ src-printer } printer set
|
||||
print-tags
|
||||
] with-scope ;
|
||||
T{ src-printer } html-printer [ print-tags ] with-variable ;
|
||||
|
||||
M: printer print-text-tag ( tag -- )
|
||||
tag-text write ;
|
||||
M: html-printer print-text-tag ( tag -- ) text>> write ;
|
||||
|
||||
M: printer print-comment-tag ( tag -- )
|
||||
"<!--" write
|
||||
tag-text write
|
||||
"-->" write ;
|
||||
M: html-printer print-comment-tag ( tag -- )
|
||||
"<!--" write text>> write "-->" write ;
|
||||
|
||||
M: printer print-dtd-tag ( tag -- )
|
||||
"<!" write
|
||||
tag-text write
|
||||
">" write ;
|
||||
|
||||
M: printer print-opening-named-tag ( tag -- )
|
||||
dup tag-name {
|
||||
{ "html" [ drop ] }
|
||||
{ "head" [ drop ] }
|
||||
{ "body" [ drop ] }
|
||||
{ "title" [ "Title: " write tag-text print ] }
|
||||
} case ;
|
||||
|
||||
M: printer print-closing-named-tag ( tag -- )
|
||||
drop ;
|
||||
M: html-printer print-dtd-tag ( tag -- )
|
||||
"<!" write text>> write ">" write ;
|
||||
|
||||
: print-attributes ( hashtable -- )
|
||||
[
|
||||
swap bl write "=" write ?quote write
|
||||
] assoc-each ;
|
||||
[ [ bl write "=" write ] [ ?quote write ] bi* ] assoc-each ;
|
||||
|
||||
M: src-printer print-opening-named-tag ( tag -- )
|
||||
M: src-printer print-opening-tag ( tag -- )
|
||||
"<" write
|
||||
[ tag-name write ]
|
||||
[ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
|
||||
[ name>> write ]
|
||||
[ attributes>> dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
|
||||
">" write ;
|
||||
|
||||
M: src-printer print-closing-named-tag ( tag -- )
|
||||
M: src-printer print-closing-tag ( tag -- )
|
||||
"</" write
|
||||
tag-name write
|
||||
name>> write
|
||||
">" write ;
|
||||
|
||||
SYMBOL: tab-width
|
||||
SYMBOL: #indentations
|
||||
SYMBOL: tagstack
|
||||
|
||||
: prettyprint-html ( vector -- )
|
||||
[
|
||||
T{ html-prettyprinter } printer set
|
||||
V{ } clone tagstack set
|
||||
2 tab-width set
|
||||
0 #indentations set
|
||||
print-tags
|
||||
] with-scope ;
|
||||
|
||||
: print-tabs ( -- )
|
||||
tab-width get #indentations get * CHAR: \s <repetition> write ;
|
||||
|
||||
M: html-prettyprinter print-opening-named-tag ( tag -- )
|
||||
M: html-prettyprinter print-opening-tag ( tag -- )
|
||||
print-tabs "<" write
|
||||
tag-name write
|
||||
name>> write
|
||||
">\n" write ;
|
||||
|
||||
M: html-prettyprinter print-closing-named-tag ( tag -- )
|
||||
M: html-prettyprinter print-closing-tag ( tag -- )
|
||||
"</" write
|
||||
tag-name write
|
||||
name>> write
|
||||
">" write ;
|
||||
|
||||
ERROR: unknown-tag-error tag ;
|
||||
|
||||
M: printer print-tag ( tag -- )
|
||||
{
|
||||
{ [ dup tag-name text = ] [ print-text-tag ] }
|
||||
{ [ dup tag-name comment = ] [ print-comment-tag ] }
|
||||
{ [ dup tag-name dtd = ] [ print-dtd-tag ] }
|
||||
{ [ dup tag-name string? over tag-closing? and ]
|
||||
[ print-closing-named-tag ] }
|
||||
{ [ dup tag-name string? ]
|
||||
[ print-opening-named-tag ] }
|
||||
[ unknown-tag-error ]
|
||||
} cond ;
|
||||
|
||||
! SYMBOL: tablestack
|
||||
! : with-html-printer ( vector quot -- )
|
||||
! [ V{ } clone tablestack set ] with-scope ;
|
||||
|
||||
! { { 1 2 } { 3 4 } }
|
||||
! H{ { table-gap { 10 10 } } } [
|
||||
! [ [ [ [ . ] with-cell ] each ] with-row ] each
|
||||
! ] tabular-output
|
||||
|
||||
! : html-pp ( vector -- )
|
||||
! [ 0 #indentations set 2 tab-width set ] with-scope ;
|
||||
|
|
|
|||
|
|
@ -4,8 +4,7 @@ namespaces prettyprint quotations sequences splitting
|
|||
state-parser strings sequences.lib ;
|
||||
IN: html.parser.utils
|
||||
|
||||
: string-parse-end? ( -- ? )
|
||||
get-next not ;
|
||||
: string-parse-end? ( -- ? ) get-next not ;
|
||||
|
||||
: take-string* ( match -- string )
|
||||
dup length <circular-string>
|
||||
|
|
@ -16,17 +15,18 @@ IN: html.parser.utils
|
|||
[ ?head drop ] [ ?tail drop ] bi ;
|
||||
|
||||
: single-quote ( str -- newstr )
|
||||
>r "'" r> "'" 3append ;
|
||||
"'" swap "'" 3append ;
|
||||
|
||||
: double-quote ( str -- newstr )
|
||||
>r "\"" r> "\"" 3append ;
|
||||
"\"" swap "\"" 3append ;
|
||||
|
||||
: quote ( str -- newstr )
|
||||
CHAR: ' over member?
|
||||
[ double-quote ] [ single-quote ] if ;
|
||||
|
||||
: quoted? ( str -- ? )
|
||||
[ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ;
|
||||
[ f ]
|
||||
[ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] if-empty ;
|
||||
|
||||
: ?quote ( str -- newstr )
|
||||
dup quoted? [ quote ] unless ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue