remove old accessors, cleanup

db4
Doug Coleman 2008-08-17 10:38:34 -05:00
parent a3e25491c0
commit 8f00739601
5 changed files with 114 additions and 164 deletions

View File

@ -56,8 +56,7 @@ TUPLE: link attributes clickable ;
: trim-text ( vector -- vector' ) : trim-text ( vector -- vector' )
[ [
dup name>> text = [ dup name>> text = [
[ text>> [ blank? ] trim ] keep [ [ blank? ] trim ] change-text
[ set-tag-text ] keep
] when ] when
] map ; ] map ;
@ -173,8 +172,7 @@ TUPLE: link attributes clickable ;
[ [
{ {
{ [ dup name>> "form" = ] { [ dup name>> "form" = ]
[ "form action: " write attributes>> "action" swap at print [ "form action: " write attributes>> "action" swap at print ] }
] }
{ [ dup name>> "input" = ] [ input. ] } { [ dup name>> "input" = ] [ input. ] }
[ drop ] [ drop ]
} cond } cond

View File

@ -2,19 +2,19 @@ USING: html.parser kernel tools.test ;
IN: html.parser.tests 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 ] [ "<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 ] [ "</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 ] [ "<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 ] [ "<a href = \"http://factorcode.org/\" >" parse-html ] unit-test
[ [
@ -26,7 +26,6 @@ V{
H{ { "baz" "\"quux\"" } { "foo" "bar's" } } H{ { "baz" "\"quux\"" } { "foo" "bar's" } }
f f
f f
f
} }
} }
] [ "<a foo=\"bar's\" baz='\"quux\"' >" parse-html ] unit-test ] [ "<a foo=\"bar's\" baz='\"quux\"' >" parse-html ] unit-test
@ -39,25 +38,25 @@ V{
{ "foo" "bar" } { "foo" "bar" }
{ "href" "http://factorcode.org/" } { "href" "http://factorcode.org/" }
{ "baz" "quux" } { "baz" "quux" }
} f f f } } f f }
} }
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test ] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
[ [
V{ V{
T{ tag f "html" H{ } f f f } T{ tag f "html" H{ } f f }
T{ tag f "head" H{ } f f f } T{ tag f "head" H{ } f f }
T{ tag f "head" H{ } f f t } T{ tag f "head" H{ } f t }
T{ tag f "html" H{ } f f t } T{ tag f "html" H{ } f t }
} }
] [ "<html<head</head</html" parse-html ] unit-test ] [ "<html<head</head</html" parse-html ] unit-test
[ [
V{ V{
T{ tag f "head" H{ } f f f } T{ tag f "head" H{ } f f }
T{ tag f "title" H{ } f f f } T{ tag f "title" H{ } f f }
T{ tag f text f "Spagna" f f } T{ tag f text f "Spagna" f }
T{ tag f "title" H{ } f f t } T{ tag f "title" H{ } f t }
T{ tag f "head" H{ } f f t } T{ tag f "head" H{ } f t }
} }
] [ "<head<title>Spagna</title></head" parse-html ] unit-test ] [ "<head<title>Spagna</title></head" parse-html ] unit-test

View File

@ -1,26 +1,22 @@
USING: accessors arrays html.parser.utils hashtables io kernel USING: accessors arrays html.parser.utils hashtables io kernel
namespaces prettyprint quotations 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 IN: html.parser
TUPLE: tag name attributes text matched? closing? ; TUPLE: tag name attributes text closing? ;
SYMBOL: text SINGLETON: text
SYMBOL: dtd SINGLETON: dtd
SYMBOL: comment SINGLETON: comment
SYMBOL: javascript
SYMBOL: tagstack SYMBOL: tagstack
: push-tag ( tag -- ) : push-tag ( tag -- )
tagstack get push ; tagstack get push ;
: closing-tag? ( string -- ? ) : closing-tag? ( string -- ? )
dup empty? [ [ f ]
drop f [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
] [
dup first CHAR: / =
swap peek CHAR: / = or
] if ;
: <tag> ( name attributes closing? -- tag ) : <tag> ( name attributes closing? -- tag )
tag new tag new
@ -28,56 +24,55 @@ SYMBOL: tagstack
swap >>attributes swap >>attributes
swap >>name ; swap >>name ;
: make-tag ( str attribs -- tag ) : make-tag ( string attribs -- tag )
>r [ closing-tag? ] keep "/" trim1 r> rot <tag> ; >r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
: make-text-tag ( str -- tag ) : make-text-tag ( string -- tag )
T{ tag f text } clone [ set-tag-text ] keep ; tag new
text >>name
swap >>text ;
: make-comment-tag ( str -- tag ) : make-comment-tag ( string -- tag )
T{ tag f comment } clone [ set-tag-text ] keep ; tag new
comment >>name
swap >>text ;
: make-dtd-tag ( str -- tag ) : make-dtd-tag ( string -- tag )
T{ tag f dtd } clone [ set-tag-text ] keep ; tag new
dtd >>name
swap >>text ;
: read-whitespace ( -- str ) : read-whitespace ( -- string )
[ get-char blank? not ] take-until ; [ get-char blank? not ] take-until ;
: read-whitespace* ( -- ) : read-whitespace* ( -- ) read-whitespace drop ;
read-whitespace drop ;
: read-token ( -- str ) : read-token ( -- string )
read-whitespace* read-whitespace*
[ get-char blank? ] take-until ; [ get-char blank? ] take-until ;
: read-single-quote ( -- str ) : read-single-quote ( -- string )
[ get-char CHAR: ' = ] take-until ; [ get-char CHAR: ' = ] take-until ;
: read-double-quote ( -- str ) : read-double-quote ( -- string )
[ get-char CHAR: " = ] take-until ; [ get-char CHAR: " = ] take-until ;
: read-quote ( -- str ) : read-quote ( -- string )
get-char next* CHAR: ' = [ get-char next* CHAR: ' =
read-single-quote [ read-single-quote ] [ read-double-quote ] if next* ;
] [
read-double-quote
] if next* ;
: read-key ( -- str ) : read-key ( -- string )
read-whitespace* read-whitespace*
[ get-char CHAR: = = get-char blank? or ] take-until ; [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
: read-= ( -- ) : read-= ( -- )
read-whitespace* read-whitespace*
[ get-char CHAR: = = ] take-until drop next* ; [ get-char CHAR: = = ] take-until drop next* ;
: read-value ( -- str ) : read-value ( -- string )
read-whitespace* read-whitespace*
get-char quote? [ get-char quote? [ read-quote ] [ read-token ] if
read-quote [ blank? ] trim ;
] [
read-token
] if [ blank? ] trim ;
: read-comment ( -- ) : read-comment ( -- )
"-->" take-string* make-comment-tag push-tag ; "-->" 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: > = get-char CHAR: < = or ] take-until
get-char CHAR: < = [ next* ] unless ; get-char CHAR: < = [ next* ] unless ;
: read-< ( -- str ) : read-< ( -- string )
next* get-char CHAR: ! = [ next* get-char CHAR: ! = [
read-bang f read-bang f
] [ ] [
read-tag read-tag
] if ; ] if ;
: read-until-< ( -- str ) : read-until-< ( -- string )
[ get-char CHAR: < = ] take-until ; [ get-char CHAR: < = ] take-until ;
: parse-text ( -- ) : parse-text ( -- )
@ -131,11 +126,9 @@ SYMBOL: tagstack
] string-parse ; ] string-parse ;
: parse-tag ( -- ) : parse-tag ( -- )
read-< dup empty? [ read-< [
drop
] [
(parse-tag) make-tag push-tag (parse-tag) make-tag push-tag
] if ; ] unless-empty ;
: (parse-html) ( -- ) : (parse-html) ( -- )
get-next [ get-next [
@ -145,13 +138,7 @@ SYMBOL: tagstack
] when ; ] when ;
: tag-parse ( quot -- vector ) : tag-parse ( quot -- vector )
[ V{ } clone tagstack [ string-parse ] with-variable ;
V{ } clone tagstack set
string-parse
] with-scope ;
: parse-html ( string -- vector ) : parse-html ( string -- vector )
[ [ (parse-html) tagstack get ] tag-parse ;
(parse-html)
tagstack get
] tag-parse ;

View File

@ -1,123 +1,89 @@
USING: assocs html.parser html.parser.utils combinators USING: accessors assocs html.parser html.parser.utils combinators
continuations hashtables continuations hashtables
hashtables.private io kernel math hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting namespaces prettyprint quotations sequences splitting
strings ; strings ;
IN: html.parser.printer IN: html.parser.printer
SYMBOL: no-section SYMBOL: printer
SYMBOL: html
SYMBOL: head
SYMBOL: body
TUPLE: state section ;
! 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 ; HOOK: print-text-tag html-printer ( tag -- )
TUPLE: ui-printer ; HOOK: print-comment-tag html-printer ( tag -- )
TUPLE: src-printer ; HOOK: print-dtd-tag html-printer ( tag -- )
TUPLE: html-prettyprinter ; HOOK: print-opening-tag html-printer ( tag -- )
UNION: printer text-printer ui-printer src-printer html-prettyprinter ; HOOK: print-closing-tag html-printer ( tag -- )
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 -- )
: print-tags ( vector -- ) ERROR: unknown-tag-error tag ;
[ print-tag ] each ;
: 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 -- ) : html-text. ( vector -- )
[ T{ text-printer } html-printer [ print-tags ] with-variable ;
T{ text-printer } printer set
print-tags
] with-scope ;
: html-src. ( vector -- ) : html-src. ( vector -- )
[ T{ src-printer } html-printer [ print-tags ] with-variable ;
T{ src-printer } printer set
print-tags
] with-scope ;
M: printer print-text-tag ( tag -- ) M: html-printer print-text-tag ( tag -- ) text>> write ;
tag-text write ;
M: printer print-comment-tag ( tag -- ) M: html-printer print-comment-tag ( tag -- )
"<!--" write "<!--" write text>> write "-->" write ;
tag-text write
"-->" write ;
M: printer print-dtd-tag ( tag -- ) M: html-printer print-dtd-tag ( tag -- )
"<!" write "<!" write text>> write ">" 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 ;
: print-attributes ( hashtable -- ) : print-attributes ( hashtable -- )
[ [ [ bl write "=" write ] [ ?quote write ] bi* ] assoc-each ;
swap bl write "=" write ?quote write
] assoc-each ;
M: src-printer print-opening-named-tag ( tag -- ) M: src-printer print-opening-tag ( tag -- )
"<" write "<" write
[ tag-name write ] [ name>> write ]
[ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi [ attributes>> dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
">" write ; ">" write ;
M: src-printer print-closing-named-tag ( tag -- ) M: src-printer print-closing-tag ( tag -- )
"</" write "</" write
tag-name write name>> write
">" write ; ">" write ;
SYMBOL: tab-width SYMBOL: tab-width
SYMBOL: #indentations 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 ( -- ) : print-tabs ( -- )
tab-width get #indentations get * CHAR: \s <repetition> write ; 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 print-tabs "<" write
tag-name write name>> write
">\n" write ; ">\n" write ;
M: html-prettyprinter print-closing-named-tag ( tag -- ) M: html-prettyprinter print-closing-tag ( tag -- )
"</" write "</" write
tag-name write name>> write
">" 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 ;

View File

@ -4,8 +4,7 @@ namespaces prettyprint quotations sequences splitting
state-parser strings sequences.lib ; state-parser strings sequences.lib ;
IN: html.parser.utils IN: html.parser.utils
: string-parse-end? ( -- ? ) : string-parse-end? ( -- ? ) get-next not ;
get-next not ;
: take-string* ( match -- string ) : take-string* ( match -- string )
dup length <circular-string> dup length <circular-string>
@ -16,17 +15,18 @@ IN: html.parser.utils
[ ?head drop ] [ ?tail drop ] bi ; [ ?head drop ] [ ?tail drop ] bi ;
: single-quote ( str -- newstr ) : single-quote ( str -- newstr )
>r "'" r> "'" 3append ; "'" swap "'" 3append ;
: double-quote ( str -- newstr ) : double-quote ( str -- newstr )
>r "\"" r> "\"" 3append ; "\"" swap "\"" 3append ;
: quote ( str -- newstr ) : quote ( str -- newstr )
CHAR: ' over member? CHAR: ' over member?
[ double-quote ] [ single-quote ] if ; [ double-quote ] [ single-quote ] if ;
: quoted? ( str -- ? ) : quoted? ( str -- ? )
[ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ; [ f ]
[ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] if-empty ;
: ?quote ( str -- newstr ) : ?quote ( str -- newstr )
dup quoted? [ quote ] unless ; dup quoted? [ quote ] unless ;