diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index f167feba06..29ccc345d3 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -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 diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index 0e98c1b998..9757f70a67 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -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 } } ] [ "" parse-html ] unit-test [ - V{ T{ tag f "html" H{ } f f t } } + V{ T{ tag f "html" H{ } f t } } ] [ "" 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 } } ] [ "" 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 } } ] [ "" parse-html ] unit-test [ @@ -26,7 +26,6 @@ V{ H{ { "baz" "\"quux\"" } { "foo" "bar's" } } f f - f } } ] [ "" parse-html ] unit-test @@ -39,25 +38,25 @@ V{ { "foo" "bar" } { "href" "http://factorcode.org/" } { "baz" "quux" } - } f f f } + } f f } } ] [ "" 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 } } ] [ "Spagna ( 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 ; -: 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 ; diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor index 27cb21a927..4419eec70e 100644 --- a/extra/html/parser/printer/printer.factor +++ b/extra/html/parser/printer/printer.factor @@ -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 ; +M: html-printer print-comment-tag ( tag -- ) + "" write ; -M: printer print-dtd-tag ( tag -- ) - "" 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 ">" 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 ">" 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 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 ">" 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 ; diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index c3372d750a..04b3687f7d 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -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 @@ -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 ;