Some minor improvements to http.server

extra/http/http-tests.factor

@@ -1,5 +1,6 @@
 USING: http tools.test multiline tuple-syntax
-io.streams.string kernel arrays splitting sequences     ;
+io.streams.string kernel arrays splitting sequences
+assocs io.sockets ;
 IN: http.tests
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@@ -136,10 +137,12 @@ io.encodings.ascii ;
 [ ] [
     [
         <dispatcher>
-        <action>
+            <action>
-            [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+                [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
-        "quit" add-responder
+            "quit" add-responder
-        "extra/http/test" resource-path <static> >>default
+            <dispatcher>
+                "extra/http/test" resource-path <static> >>default
+            "nested" add-responder
         main-responder set
 
         [ 1237 httpd ] "HTTPD test" spawn drop
@@ -148,7 +151,17 @@ io.encodings.ascii ;
 
 [ t ] [
     "extra/http/test/foo.html" resource-path ascii file-contents
-    "http://localhost:1237/foo.html" http-get =
+    "http://localhost:1237/nested/foo.html" http-get =
+] unit-test
+
+! Try with a slightly malformed request
+[ t ] [
+    "localhost" 1237 <inet> ascii <client> [
+        "GET nested HTTP/1.0\r\n" write flush
+        "\r\n" write flush
+        readln drop
+        read-header USE: prettyprint
+    ] with-stream dup . "location" swap at "/" head?
 ] unit-test
 
 [ "Goodbye" ] [

extra/http/server/auth/login/Untitled-13

@@ -0,0 +1,7 @@
+hidden, how do we handle this?
+
+dan's delegation is the obvious solution.
+
+but... we have that ugly hack for integers there...
+
+i have hidden string, hidden username... hmmm....

extra/http/server/auth/login/login.factor

@@ -1,20 +1,29 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors quotations assocs kernel splitting
-base64 html.elements io combinators http.server
+base64 io combinators sequences io.files namespaces hashtables
-http.server.auth.providers http.server.auth.providers.null
-http.server.actions http.server.components http.server.sessions
-http.server.templating.fhtml http.server.validators
-http.server.auth http sequences io.files namespaces hashtables
 fry io.sockets arrays threads locals qualified continuations
-destructors ;
+destructors
+
+html.elements
+http
+http.server
+http.server.auth
+http.server.auth.providers
+http.server.auth.providers.null
+http.server.actions
+http.server.components
+http.server.forms
+http.server.sessions
+http.server.templating.fhtml
+http.server.validators ;
 IN: http.server.auth.login
 QUALIFIED: smtp
 
 SYMBOL: post-login-url
 SYMBOL: login-failed?
 
-TUPLE: login users ;
+TUPLE: login < dispatcher users ;
 
 : users login get users>> ;
 
@@ -130,7 +139,7 @@ SYMBOL: user-exists?
 
                 successful-login
 
-                login get responder>> init-user-profile
+                login get default>> responder>> init-user-profile
             ] >>submit
     ] ;
 
@@ -178,7 +187,7 @@ SYMBOL: previous-page
                     "password" value uid users check-login
                     [ login-failed? on validation-failed ] unless
 
-                    "new-password" value set-password
+                    "new-password" value >>password
                 ] unless
 
                 "realname" value >>realname
@@ -269,7 +278,8 @@ SYMBOL: lost-password-from
 : <recover-form-3>
     "new-password" <form>
         "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template
-        "username" <username> <hidden>
+        "username" <username>
+            hidden >>renderer
             t >>required
             add-field
         "new-password" <password>
@@ -278,7 +288,8 @@ SYMBOL: lost-password-from
         "verify-password" <password>
             t >>required
             add-field
-        "ticket" <string> <hidden>
+        "ticket" <string>
+            hidden >>renderer
             t >>required
             add-field ;
 
@@ -342,22 +353,22 @@ C: <protected> protected
     "login" f <permanent-redirect> ;
 
 M: protected call-responder ( path responder -- response )
-    logged-in-user sget [
+    logged-in-user sget dup [
-        dup save-user-after
+        save-user-after
         request get request-url previous-page sset
         responder>> call-responder
     ] [
-        2drop
+        3drop
         request get method>> { "GET" "HEAD" } member?
         [ show-login-page ] [ <400> ] if
     ] if ;
 
 M: login call-responder ( path responder -- response )
     dup login set
-    delegate call-responder ;
+    call-next-method ;
 
 : <login> ( responder -- auth )
-    login <webapp>
+    login new-dispatcher
         swap <protected> >>default
         <login-action> "login" add-responder
         <logout-action> "logout" add-responder

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -26,7 +26,7 @@ namespaces accessors kernel ;
 
 [ t ] [ "user" get >boolean ] unit-test
 
-[ ] [ "user" get "fdasf" set-password drop ] unit-test
+[ ] [ "user" get "fdasf" >>password drop ] unit-test
 
 [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
 

extra/http/server/auth/providers/db/db-tests.factor

@@ -31,7 +31,7 @@ users-in-db "provider" set
 
     [ t ] [ "user" get >boolean ] unit-test
 
-    [ ] [ "user" get "fdasf" set-password drop ] unit-test
+    [ ] [ "user" get "fdasf" >>password drop ] unit-test
 
     [ ] [ "user" get "provider" get update-user ] unit-test
 

extra/http/server/auth/providers/providers.factor

@@ -17,8 +17,6 @@ GENERIC: new-user ( user provider -- user/f )
 : check-login ( password username provider -- user/f )
     get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
 
-: set-password ( user password -- user ) >>password ;
-
 ! Password recovery support
 
 :: issue-ticket ( email username provider -- user/f )

extra/http/server/components/components-tests.factor

@@ -1,7 +1,10 @@
 IN: http.server.components.tests
-USING: http.server.components http.server.validators
+USING: http.server.components http.server.forms
-namespaces tools.test kernel accessors
+http.server.validators namespaces tools.test kernel accessors
-tuple-syntax mirrors http.server.actions ;
+tuple-syntax mirrors http.server.actions
+io.streams.string io.streams.null ;
+
+\ render-edit must-infer
 
 validation-failed? off
 
@@ -99,11 +102,31 @@ TUPLE: test-tuple text number more-text ;
         "123" "n" get validate value>>
     ] unit-test
     
-    [ ] [ "n" get t >>integer drop ] unit-test
+    [ ] [ "i" <integer> "i" set ] unit-test
 
     [ 3 ] [
-        "3" "n" get validate
+        "3" "i" get validate
     ] unit-test
+    
+    [ t ] [
+        "3.9" "i" get validate validation-error?
+    ] unit-test
+
+    H{ } clone values set
+
+    [ ] [ 3 "i" set-value ] unit-test
+
+    [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test
+
+    [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test
+
+    [ ] [ "t" <text> "t" set ] unit-test
+
+    [ ] [ "hello world" "t" set-value ] unit-test
+
+    [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test
 ] with-scope
 
 [ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
+
+[ ] [ "password" <password> "p" set ] unit-test

extra/http/server/components/components.factor

@@ -2,23 +2,47 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: html.elements http.server.validators accessors namespaces
 kernel io math.parser assocs classes words classes.tuple arrays
-sequences io.files http.server.templating.fhtml
+sequences splitting mirrors hashtables fry combinators
-http.server.actions splitting mirrors hashtables fry
 continuations math ;
 IN: http.server.components
 
+! Renderer protocol
+GENERIC: render-view* ( value renderer -- )
+GENERIC: render-edit* ( value id renderer -- )
+
+TUPLE: field type ;
+
+C: <field> field
+
+M: field render-view* drop write ;
+
+M: field render-edit*
+    <input type>> =type [ =id ] [ =name ] bi =value input/> ;
+
+: render-error ( message -- )
+    <span "error" =class span> write </span> ;
+
+TUPLE: hidden < field ;
+
+: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
+
+M: hidden render-view* 2drop ;
+
+! Component protocol
 SYMBOL: components
 
-TUPLE: component id required default ;
+TUPLE: component id required default renderer ;
 
 : component ( name -- component )
     dup components get at
     [ ] [ "No such component: " prepend throw ] ?if ;
 
+GENERIC: init ( component -- component )
+
+M: component init ;
+
 GENERIC: validate* ( value component -- result )
-GENERIC: render-view* ( value component -- )
+GENERIC: component-string ( value component -- string )
-GENERIC: render-edit* ( value component -- )
-GENERIC: render-error* ( reason value component -- )
 
 SYMBOL: values
 
@@ -26,6 +50,41 @@ SYMBOL: values
 
 : set-value values get set-at ;
 
+: blank-values H{ } clone values set ;
+
+: from-tuple <mirror> values set ;
+
+: values-tuple values get mirror-object ;
+
+: render-view ( component -- )
+    [ id>> value ] [ component-string ] [ renderer>> ] tri
+    render-view* ;
+
+<PRIVATE
+
+: render-edit-string ( string component -- )
+    [ id>> ] [ renderer>> ] bi render-edit* ;
+
+: render-edit-error ( component -- )
+    [ id>> value ] keep
+    [ [ value>> ] dip render-edit-string ]
+    [ drop reason>> render-error ] 2bi ;
+
+: value-or-default ( component -- value )
+    [ id>> value ] [ default>> ] bi or ;
+
+: render-edit-value ( component -- )
+    [ value-or-default ]
+    [ component-string ]
+    [ render-edit-string ]
+    tri ;
+
+PRIVATE>
+
+: render-edit ( component -- )
+    dup id>> value validation-error?
+    [ render-edit-error ] [ render-edit-value ] if ;
+
 : validate ( value component -- result )
     '[
         ,
@@ -36,206 +95,130 @@ SYMBOL: values
         ] [ validate* ] if
     ] with-validator ;
 
-: render-view ( component -- )
+: new-component ( id class renderer -- component )
-    [ id>> value ] [ render-view* ] bi ;
+    swap construct-empty
-
+        swap >>renderer
-: render-error ( error -- )
+        swap >>id
-    <span "error" =class span> write </span> ;
+        init ; inline
-
-: render-edit ( component -- )
-    dup id>> value dup validation-error? [
-        [ reason>> ] [ value>> ] bi rot render-error*
-    ] [
-        swap [ default>> or ] keep render-edit*
-    ] if ;
-
-: <component> ( id class -- component )
-    \ component construct-empty
-    swap construct-delegate
-    swap >>id ; inline
-
-! Forms
-TUPLE: form view-template edit-template components ;
-
-: <form> ( id -- form )
-    form <component>
-        V{ } clone >>components ;
-
-: add-field ( form component -- form )
-    dup id>> pick components>> set-at ;
-
-: with-form ( form quot -- )
-    >r components>> components r> with-variable ; inline
-
-: set-defaults ( form -- )
-    [
-        components get [
-            swap values get [
-                swap default>> or
-            ] change-at
-        ] assoc-each
-    ] with-form ;
-
-: view-form ( form -- )
-    dup view-template>> '[ , run-template ] with-form ;
-
-: edit-form ( form -- )
-    dup edit-template>> '[ , run-template ] with-form ;
-
-: validate-param ( id component -- )
-    [ [ params get at ] [ validate ] bi* ]
-    [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
-    [
-        validation-failed? off
-        components get [ validate-param ] assoc-each
-        validation-failed? get
-    ] with-form ;
-
-: validate-form ( form -- )
-    (validate-form) [ validation-failed ] when ;
-
-: blank-values H{ } clone values set ;
-
-: from-tuple <mirror> values set ;
-
-: values-tuple values get mirror-object ;
-
-! ! !
-! Canned components: for simple applications and prototyping
-! ! !
-
-: render-input ( value component type -- )
-    <input
-    =type
-    id>> [ =id ] [ =name ] bi
-    =value
-    input/> ;
-
-! Hidden fields
-TUPLE: hidden ;
-
-: <hidden> ( component -- component )
-    hidden construct-delegate ;
-
-M: hidden render-view*
-    2drop ;
-
-M: hidden render-edit*
-    >r dup number? [ number>string ] when r>
-    "hidden" render-input ;
 
 ! String input fields
-TUPLE: string min-length max-length ;
+TUPLE: string < component one-line min-length max-length ;
 
-: <string> ( id -- component ) string <component> ;
+: new-string ( id class -- component )
+    "text" <field> new-component
+        t >>one-line ; inline
+
+: <string> ( id -- component )
+    string new-string ;
 
 M: string validate*
-    [ v-one-line ] [
+    [   one-line>> [ v-one-line   ] when  ]
-        [ min-length>> [ v-min-length ] when* ]
+    [ min-length>> [ v-min-length ] when* ]
-        [ max-length>> [ v-max-length ] when* ]
+    [ max-length>> [ v-max-length ] when* ]
-        bi
+    tri ;
-    ] bi* ;
 
-M: string render-view*
+M: string component-string
-    drop write ;
+    drop ;
-
-M: string render-edit*
-    "text" render-input ;
-
-M: string render-error*
-    "text" render-input render-error ;
 
 ! Username fields
-TUPLE: username ;
+TUPLE: username < string ;
+
+M: username init
+    2 >>min-length
+    20 >>max-length ;
 
 : <username> ( id -- component )
-    <string> username construct-delegate
+    username new-string ;
-        2 >>min-length
-        20 >>max-length ;
 
 M: username validate*
-    delegate validate* v-one-word ;
+    call-next-method v-one-word ;
 
 ! E-mail fields
-TUPLE: email ;
+TUPLE: email < string ;
 
 : <email> ( id -- component )
-    <string> email construct-delegate
+    email new-string
         5 >>min-length
         60 >>max-length ;
 
 M: email validate*
-    delegate validate* dup empty? [ v-email ] unless ;
+    call-next-method dup empty? [ v-email ] unless ;
+
+! Don't send passwords back to the user
+TUPLE: password-renderer < field ;
+
+: password-renderer T{ password-renderer f "password" } ;
+
+: blank-password >r >r drop "" r> r> ;
+
+M: password-renderer render-edit*
+    blank-password call-next-method ;
 
 ! Password fields
-TUPLE: password ;
+TUPLE: password < string ;
+
+M: password init
+    6 >>min-length
+    60 >>max-length ;
 
 : <password> ( id -- component )
-    <string> password construct-delegate
+    password new-string
-        6 >>min-length
+        password-renderer >>renderer ;
-        60 >>max-length ;
 
 M: password validate*
-    delegate validate* v-one-word ;
+    call-next-method v-one-word ;
-
-M: password render-edit*
-    >r drop f r> "password" render-input ;
-
-M: password render-error*
-    render-edit* render-error ;
 
 ! Number fields
-TUPLE: number min-value max-value integer ;
+TUPLE: number < string min-value max-value ;
 
-: <number> ( id -- component ) number <component> ;
+: <number> ( id -- component )
+    number new-string ;
 
 M: number validate*
     [ v-number ] [
-        [ integer>> [ v-integer ] when ]
         [ min-value>> [ v-min-value ] when* ]
         [ max-value>> [ v-max-value ] when* ]
-        tri
+        bi
     ] bi* ;
 
-M: number render-view*
+M: number component-string
-    drop number>string write ;
+    drop dup [ number>string ] when ;
 
-M: number render-edit*
+! Integer fields
-    >r number>string r> "text" render-input ;
+TUPLE: integer < number ;
 
-M: number render-error*
+: <integer> ( id -- component )
-    "text" render-input render-error ;
+    integer new-string ;
 
-! Text areas
+M: integer validate*
-TUPLE: text ;
+    call-next-method v-integer ;
-
-: <text> ( id -- component ) text <component> ;
-
-M: text validate* drop ;
-
-M: text render-view*
-    drop write ;
-
-: render-textarea
-    <textarea
-        id>> [ =id ] [ =name ] bi
-    textarea>
-        write
-    </textarea> ;
-
-M: text render-edit*
-    render-textarea ;
-
-M: text render-error*
-    render-textarea render-error ;
 
 ! Simple captchas
-TUPLE: captcha ;
+TUPLE: captcha < string ;
 
 : <captcha> ( id -- component )
-    <string> captcha construct-delegate ;
+    captcha new-string ;
 
 M: captcha validate*
     drop v-captcha ;
+
+! Text areas
+TUPLE: textarea-renderer ;
+
+: textarea-renderer T{ textarea-renderer } ;
+
+M: textarea-renderer render-view*
+    drop write ;
+
+M: textarea-renderer render-edit*
+    drop <textarea [ =id ] [ =name ] bi textarea> write </textarea> ;
+
+TUPLE: text < string ;
+
+: new-text ( id class -- component )
+    new-string
+        f >>one-line
+        textarea-renderer >>renderer ;
+
+: <text> ( id -- component )
+    text new-text ;

extra/http/server/components/farkup/farkup.factor

@@ -1,13 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: splitting http.server.components kernel io sequences
+USING: splitting kernel io sequences farkup accessors
-farkup ;
+http.server.components ;
 IN: http.server.components.farkup
 
-TUPLE: farkup ;
+TUPLE: farkup-renderer < textarea-renderer ;
+
+: farkup-renderer T{ farkup-renderer } ;
+
+M: farkup-renderer render-view*
+    drop string-lines "\n" join convert-farkup write ;
 
 : <farkup> ( id -- component )
-    <text> farkup construct-delegate ;
+    <text>
-
+        farkup-renderer >>renderer ;
-M: farkup render-view*
-    drop string-lines "\n" join convert-farkup write ;

extra/http/server/db/db.factor

@@ -9,8 +9,8 @@ TUPLE: db-persistence responder db params ;
 C: <db-persistence> db-persistence
 
 : connect-db ( db-persistence -- )
-    [ db>> ] [ params>> ] bi make-db
+    [ db>> ] [ params>> ] bi make-db db-open
-    [ db set ] [ db-open ] [ add-always-destructor ] tri ;
+    [ db set ] [ add-always-destructor ] bi ;
 
 M: db-persistence call-responder
     [ connect-db ] [ responder>> call-responder ] bi ;

extra/http/server/forms/forms.factor

@@ -0,0 +1,48 @@
+USING: kernel accessors assocs namespaces io.files fry
+http.server.actions
+http.server.components
+http.server.validators
+http.server.templating.fhtml ;
+IN: http.server.forms
+
+TUPLE: form < component view-template edit-template components ;
+
+M: form init V{ } clone >>components ;
+
+: <form> ( id -- form )
+    form f new-component ;
+
+: add-field ( form component -- form )
+    dup id>> pick components>> set-at ;
+
+: with-form ( form quot -- )
+    >r components>> components r> with-variable ; inline
+
+: set-defaults ( form -- )
+    [
+        components get [
+            swap values get [
+                swap default>> or
+            ] change-at
+        ] assoc-each
+    ] with-form ;
+
+: view-form ( form -- )
+    dup view-template>> '[ , run-template ] with-form ;
+
+: edit-form ( form -- )
+    dup edit-template>> '[ , run-template ] with-form ;
+
+: validate-param ( id component -- )
+    [ [ params get at ] [ validate ] bi* ]
+    [ drop set-value ] 2bi ;
+
+: (validate-form) ( form -- error? )
+    [
+        validation-failed? off
+        components get [ validate-param ] assoc-each
+        validation-failed? get
+    ] with-form ;
+
+: validate-form ( form -- )
+    (validate-form) [ validation-failed ] when ;

extra/http/server/server.factor

@@ -105,8 +105,13 @@ SYMBOL: form-hook
 
 TUPLE: dispatcher default responders ;
 
+: new-dispatcher ( class -- dispatcher )
+    construct-empty
+        404-responder get >>default
+        H{ } clone >>responders ; inline
+
 : <dispatcher> ( -- dispatcher )
-    404-responder get H{ } clone dispatcher construct-boa ;
+    dispatcher new-dispatcher ;
 
 : split-path ( path -- rest first )
     [ CHAR: / = ] left-trim "/" split1 swap ;
@@ -125,9 +130,6 @@ M: dispatcher call-responder ( path dispatcher -- response )
         2drop redirect-with-/
     ] if ;
 
-: <webapp> ( class -- dispatcher )
-    <dispatcher> swap construct-delegate ; inline
-
 TUPLE: vhost-dispatcher default responders ;
 
 : <vhost-dispatcher> ( -- dispatcher )

extra/http/server/sessions/sessions.factor

@@ -17,9 +17,10 @@ M: object init-session* drop ;
 
 TUPLE: session-manager responder sessions ;
 
-: <session-manager> ( responder class -- responder' )
+: construct-session-manager ( responder class -- responder' )
-    >r <sessions-in-memory> session-manager construct-boa
+    construct-empty
-    r> construct-delegate ; inline
+        <sessions-in-memory> >>sessions
+        swap >>responder ; inline
 
 SYMBOLS: session session-id session-changed? ;
 
@@ -64,18 +65,18 @@ M: session-saver dispose
     [ [ session-id set ] [ session set ] bi* ] 2bi
     [ session-manager set ] [ responder>> call-responder ] bi ;
 
-TUPLE: null-sessions ;
+TUPLE: null-sessions < session-manager ;
 
 : <null-sessions>
-    null-sessions <session-manager> ;
+    null-sessions construct-session-manager ;
 
 M: null-sessions call-responder ( path responder -- response )
     H{ } clone f call-responder/session ;
 
-TUPLE: url-sessions ;
+TUPLE: url-sessions < session-manager ;
 
 : <url-sessions> ( responder -- responder' )
-    url-sessions <session-manager> ;
+    url-sessions construct-session-manager ;
 
 : session-id-key "factorsessid" ;
 
@@ -107,10 +108,10 @@ M: url-sessions call-responder ( path responder -- response )
         2drop nip new-url-session
     ] if ;
 
-TUPLE: cookie-sessions ;
+TUPLE: cookie-sessions < session-manager ;
 
 : <cookie-sessions> ( responder -- responder' )
-    cookie-sessions <session-manager> ;
+    cookie-sessions construct-session-manager ;
 
 : current-cookie-session ( responder -- id namespace/f )
     request get session-id-key get-cookie dup

extra/http/server/templating/fhtml/fhtml.factor

@@ -1,25 +1,22 @@
 ! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations sequences kernel parser namespaces io
 io.files io.streams.string html html.elements source-files
 debugger combinators math quotations generic strings splitting
 accessors http.server.static http.server assocs
-io.encodings.utf8 fry ;
+io.encodings.utf8 fry accessors ;
 
 IN: http.server.templating.fhtml
 
 : templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
 
-! See apps/http-server/test/ or libs/furnace/ for template usage
-! examples
-
 ! We use a custom lexer so that %> ends a token even if not
 ! followed by whitespace
-TUPLE: template-lexer ;
+TUPLE: template-lexer < lexer ;
 
 : <template-lexer> ( lines -- lexer )
-    <lexer> template-lexer construct-delegate ;
+    template-lexer construct-lexer ;
 
 M: template-lexer skip-word
     [
@@ -33,18 +30,18 @@ M: template-lexer skip-word
 DEFER: <% delimiter
 
 : check-<% ( lexer -- col )
-    "<%" over lexer-line-text rot lexer-column start* ;
+    "<%" over line-text>> rot column>> start* ;
 
 : found-<% ( accum lexer col -- accum )
     [
-        over lexer-line-text
+        over line-text>>
-        >r >r lexer-column r> r> subseq parsed
+        >r >r column>> r> r> subseq parsed
         \ write-html parsed
-    ] 2keep 2 + swap set-lexer-column ;
+    ] 2keep 2 + >>column drop ;
 
 : still-looking ( accum lexer -- accum )
     [
-        dup lexer-line-text swap lexer-column tail
+        [ line-text>> ] [ column>> ] bi tail
         parsed \ print-html parsed
     ] keep next-line ;