update handling of %-escapes in urls

[wix.git] / src / Doc.lhs

diff --git a/src/Doc.lhs b/src/Doc.lhs
index 5890439..6d1baa7 100644 (file)
--- a/src/Doc.lhs
+++ b/src/Doc.lhs
@@ -1,10 +1,14 @@
 \begin{code}
+-- Copyright 2008 the Contributors, as shown in the revision logs.
+-- Licensed under the Apache Public Source License 2.0 ("the License").
+-- You may not use this file except in compliance with the License.
+
 module Doc
 where
 import Numeric
 import Data.Bits
 import Data.Char
-import Edu.Berkeley.Sbp.Haskell.SBP
+import Edu_Berkeley_Sbp_Haskell_SBP
 import Util
 import FromTree
 import qualified Text.PrettyPrint.Leijen as PP
@@ -118,7 +122,7 @@ unindent (Tree "I" indent _) v = unindent' ((length indent)+1) v
 
 instance FromTree [Text] where
   fromTree (Tree "Word"    chars       _) = [Chars              $ concatMap fromTree chars]
-  fromTree (Tree "Ordinal" x           _) = [Command "ordinal"  $ [Chars (show x)]]
+  fromTree (Tree "Ordinal" x           _) = [Command "ordinal"  $ [Chars $ concatMap show x]]
   fromTree (Tree "Fraction" [n,d]      _) = [Command "fraction" $ [(Chars (show n)), (Chars (show d))]]
   fromTree (Tree "WS"     _            _) = [WS]
   fromTree (Tree "Quotes" [x]          _) = [Quotes $ fromTree x]
@@ -178,11 +182,13 @@ instance Show URL where
 instance FromTree URL where
   fromTree (Tree "URL"   stuff                         _) = fromTrees stuff
   fromTree (Tree "Email" [(Tree "username" un _),host] _) = Email (fromTrees un) (fromTree host)
-  fromTree (Tree "Path"  stuff                         _) = URLPath $ map fromUrlChar stuff
-   where
-    fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = chr $ (fst $ head $ readHex (a++b))
-    fromUrlChar (Tree [c] []                            _) = c
-    fromUrlChar t                                          = error $ "could not parse as an url char: " ++ (show t)
+  fromTree (Tree "Path"  stuff                         _) = URLPath $ concatMap fromUrlChar stuff
+
+--fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = chr $ (fst $ head $ readHex (a++b))
+-- FIXME: problem here is the "/" vs "%2F" issue, so we "leave urls urlencoded"
+fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = "%"++a++b
+fromUrlChar (Tree [c] []                            _) = [c]
+fromUrlChar t                                          = error $ "could not parse as an url char: " ++ (show t)
 
 fromTreeChildren (Tree _ c _) = fromTrees c
 instance FromTrees URL where
@@ -191,7 +197,7 @@ instance FromTrees URL where
          url_host   = fromTree host,
          url_login  = Nothing,
          url_port   = case port of { (Tree "Port" port _) -> Just $ fromTrees port; _ -> Nothing },
-         url_path   = case rest of { ((Tree "Path" p _):_) -> fromTrees p; _ -> "" },
+         url_path   = case rest of { ((Tree "Path" p _):_) -> concatMap fromUrlChar p; _ -> "" },
          url_ref    = case rest of { (_:(Tree "Path" r _):_) -> Just $ fromTrees r; _ -> Nothing }
        }
  fromTrees x = error $ show x