punycode: remove IRL in favor of >idna and idna> generics.

diff --git a/extra/punycode/punycode-tests.factor b/extra/punycode/punycode-tests.factor
index 624bc94909038b880394b76633c359578a0427d2..d5490afbb6da96e88082e38cd0cf46173a16b87b 100644 (file)
--- a/extra/punycode/punycode-tests.factor
+++ b/extra/punycode/punycode-tests.factor
@@ -149,11 +149,10 @@ tools.test urls ;
     [ 1array swap '[ _ >idna ] unit-test ] 2bi
 ] assoc-each
 
-{ IRL" http://例子.卷筒纸" } [ URL" http://xn--fsqu00a.xn--3lr804guic/" >irl ] unit-test
-{ URL" http://xn--fsqu00a.xn--3lr804guic/" } [ IRL" http://例子.卷筒纸" >url ] unit-test
-
+{ URL" http://例子.卷筒纸" } [ URL" http://xn--fsqu00a.xn--3lr804guic/" >idna ] unit-test
+{ URL" http://xn--fsqu00a.xn--3lr804guic/" } [ URL" http://例子.卷筒纸" idna> ] unit-test
 {
-    T{ irl
+    T{ url
         { protocol "http" }
         { username f }
         { password f }

diff --git a/extra/punycode/punycode.factor b/extra/punycode/punycode.factor
index 4156deb73b1afa17f8a47554a7eca9aa6137b59d..f3a7c73e06a458eea62992b0cae93d5fa83a0ddb 100644 (file)
--- a/extra/punycode/punycode.factor
+++ b/extra/punycode/punycode.factor
@@ -156,141 +156,22 @@ PRIVATE>
         SBUF" " clone swap >upper
     ] if* insertion-sort "" like ;
 
-: idna> ( punycode -- str )
+GENERIC: idna> ( punycode -- obj )
+
+M: object idna>
     "." split [
         "xn--" ?head [ punycode> ] when
     ] map "." join ;
 
-: >idna ( str -- punycode )
+M: url idna> [ idna> ] change-host ;
+
+GENERIC: >idna ( obj -- punycode )
+
+M: object >idna
     "." split [
         dup [ N < ] all? [
             >punycode "xn--" prepend
         ] unless
     ] map "." join ;
 
-TUPLE: irl < url ;
-
-: <irl> ( -- irl ) irl new ;
-
-GENERIC: >irl ( obj -- irl )
-
-M: f >irl drop <irl> ;
-
-<PRIVATE
-
-: irl-decode ( str -- str' )
-    "" like R/ (%[a-fA-F0-9]{2})+/ [ url-decode ] re-replace-with ;
-
-: iquery-decode ( str -- decoded )
-    "+" split "%20" join irl-decode ;
-
-: iquery>assoc ( query -- assoc )
-    dup [
-        "&;" split <linked-hash> [
-            [
-                [ "=" split1 [ dup [ iquery-decode ] when ] bi@ swap ] dip
-                add-query-param
-            ] curry each
-        ] keep
-    ] when ;
-
-: assoc>iquery ( assoc -- str )
-    [
-        [
-            [
-                dup array? [ 1array ] unless
-                [ "=" glue , ] with each
-            ] [ , ] if*
-        ] assoc-each
-    ] { } make "&" join ;
-
-! RFC 3987
-EBNF: parse-irl [=[
-
-protocol = [a-zA-Z0-9.+-]+ => [[ irl-decode ]]
-username = [^/:@#?]+       => [[ irl-decode ]]
-password = [^/:@#?]+       => [[ irl-decode ]]
-path     = [^#?]+          => [[ irl-decode ]]
-query    = [^#]+           => [[ iquery>assoc ]]
-anchor   = .+              => [[ irl-decode ]]
-hostname = [^/#?:]+        => [[ irl-decode ]]
-port     = [^/#?]+         => [[ url-decode parse-port ]]
-
-auth     = username (":"~ password)? "@"~
-host     = hostname (":"~ port)?
-
-url      = (protocol ":"~)?
-           ("//"~ auth? host?)?
-           path?
-           ("?"~ query)?
-           ("#"~ anchor)?
-
-]=]
-
-: unparse-ihost-part ( url -- )
-    {
-        [ unparse-username-password ]
-        [ host>> % ]
-        [ url-port [ ":" % # ] when* ]
-        [ path>> "/" head? [ "/" % ] unless ]
-    } cleave ;
-
-: unparse-iauthority ( url -- )
-    dup host>> [ "//" % unparse-ihost-part ] [ drop ] if ;
-
-M: irl present
-    [
-        {
-            [ unparse-protocol ]
-            [ unparse-iauthority ]
-            [ path>> % ]
-            [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>iquery % ] if ]
-            [ anchor>> [ "#" % present % ] when* ]
-        } cleave
-    ] "" make ;
-
-PRIVATE>
-
-M: string >irl
-    [ <irl> ] dip parse-irl 5 firstn {
-        [ >lower >>protocol ]
-        [
-            [
-                [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
-                [ second [ first2 [ >>host ] [ >>port ] bi* ] when* ] bi
-            ] when*
-        ]
-        [ >>path ]
-        [ >>query ]
-        [ >>anchor ]
-    } spread dup host>> [ [ "/" or ] change-path ] when ;
-
-M: irl >url
-    [ <url> ] dip {
-        [ protocol>> >>protocol ]
-        [ username>> >>username ]
-        [ password>> >>password ]
-        [ host>> [ >idna ] [ f ] if* >>host ]
-        [ port>> >>port ]
-        [ path>> >>path ]
-        [ query>> >>query ]
-        [ anchor>> >>anchor ]
-    } cleave ;
-
-M: url >irl
-    [ <irl> ] dip {
-        [ protocol>> >>protocol ]
-        [ username>> >>username ]
-        [ password>> >>password ]
-        [ host>> [ idna> ] [ f ] if* >>host ]
-        [ port>> >>port ]
-        [ path>> >>path ]
-        [ query>> >>query ]
-        [ anchor>> >>anchor ]
-    } cleave ;
-
-SYNTAX: IRL" lexer get skip-blank parse-string >irl suffix! ;
-
-M: irl pprint*
-    \ IRL" record-vocab
-    dup present "IRL\" " "\"" pprint-string ;
+M: url >idna [ >idna ] change-host ;