WIP

src/Data/URI/AbsoluteURI.purs

@@ -1,74 +1,84 @@
 module Data.URI.AbsoluteURI
   ( AbsoluteURI(..)
-  , parse
   , parser
   , print
   , _scheme
   , _hierPart
   , _query
   , module Data.URI.HierarchicalPart
-  , module Data.URI.Query
   , module Data.URI.Scheme
   ) where
 
 import Prelude
 
 import Data.Array (catMaybes)
-import Data.Either (Either)
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
 import Data.Lens (Lens', lens)
 import Data.Maybe (Maybe(..))
 import Data.String as S
 import Data.URI.HierarchicalPart as HPart
-import Data.URI.HierarchicalPart (Authority(..), HierarchicalPart(..), Host(..), Port(..), URIPath, URIPathAbs, URIPathRel, UserInfo(..), _IPv4Address, _IPv6Address, _NameAddress, _authority, _hosts, _path, _userInfo)
+import Data.URI.HierarchicalPart (Authority(..), HierarchicalPart(..), Host(..), Port(..), UserInfo(..), _IPv4Address, _IPv6Address, _NameAddress, _authority, _hosts, _path, _userInfo)
 import Data.URI.Query as Query
-import Data.URI.Query (Query(..))
 import Data.URI.Scheme as Scheme
 import Data.URI.Scheme (Scheme(..))
-import Text.Parsing.StringParser (ParseError, Parser, runParser)
+import Text.Parsing.StringParser (Parser)
 import Text.Parsing.StringParser.Combinators (optionMaybe)
 import Text.Parsing.StringParser.String (eof)
 
--- | An absolute URI.
-data AbsoluteURI = AbsoluteURI Scheme HierarchicalPart (Maybe Query)
+-- | An absolute AbsoluteURI.
+data AbsoluteURI userInfo path query = AbsoluteURI Scheme (HierarchicalPart userInfo path) (Maybe query)
 
-derive instance eqAbsoluteURI ∷ Eq AbsoluteURI
-derive instance ordAbsoluteURI ∷ Ord AbsoluteURI
-derive instance genericAbsoluteURI ∷ Generic AbsoluteURI _
-instance showAbsoluteURI ∷ Show AbsoluteURI where show = genericShow
+derive instance eqAbsoluteURI ∷ (Eq userInfo, Eq path, Eq query) ⇒ Eq (AbsoluteURI userInfo path query)
+derive instance ordAbsoluteURI ∷ (Ord userInfo, Ord path, Ord query) ⇒ Ord (AbsoluteURI userInfo path query)
+derive instance genericAbsoluteURI ∷ Generic (AbsoluteURI userInfo path query) _
+instance showAbsoluteURI ∷ (Show userInfo, Show path, Show query) ⇒ Show (AbsoluteURI userInfo path query) where show = genericShow
 
-parse ∷ String → Either ParseError AbsoluteURI
-parse = runParser parser
-
-parser ∷ Parser AbsoluteURI
-parser = AbsoluteURI
+parser
+  ∷ ∀ userInfo path query
+  . Parser userInfo
+  → Parser path
+  → Parser query
+  → Parser (AbsoluteURI userInfo path query)
+parser parseUserInfo parsePath parseQuery = AbsoluteURI
   <$> Scheme.parser
-  <*> HPart.parser
-  <*> optionMaybe Query.parser
+  <*> HPart.parser parseUserInfo parsePath
+  <*> optionMaybe (Query.parser' parseQuery)
   <* eof
 
-print ∷ AbsoluteURI → String
-print (AbsoluteURI s h q) =
+print
+  ∷ ∀ userInfo path query
+  . (userInfo → String)
+  → (path → String)
+  → (query → String)
+  → AbsoluteURI userInfo path query
+  → String
+print printUserInfo printPath printQuery (AbsoluteURI s h q) =
   S.joinWith "" $ catMaybes
     [ Just (Scheme.print s)
-    , Just (HPart.print h)
-    , Query.print <$> q
+    , Just (HPart.print printUserInfo printPath h)
+    , Query.print' printQuery <$> q
     ]
 
-_scheme ∷ Lens' AbsoluteURI Scheme
+_scheme
+  ∷ ∀ userInfo path query
+  . Lens' (AbsoluteURI userInfo path query) Scheme
 _scheme =
   lens
     (\(AbsoluteURI s _ _) → s)
     (\(AbsoluteURI _ h q) s → AbsoluteURI s h q)
 
-_hierPart ∷ Lens' AbsoluteURI HierarchicalPart
+_hierPart
+  ∷ ∀ userInfo path query
+  . Lens' (AbsoluteURI userInfo path query) (HierarchicalPart userInfo path)
 _hierPart =
   lens
     (\(AbsoluteURI _ h _) → h)
     (\(AbsoluteURI s _ q) h → AbsoluteURI s h q)
 
-_query ∷ Lens' AbsoluteURI (Maybe Query)
+_query
+  ∷ ∀ userInfo path query
+  . Lens' (AbsoluteURI userInfo path query) (Maybe query)
 _query =
   lens
     (\(AbsoluteURI _ _ q) → q)

src/Data/URI/Authority.purs

@@ -30,37 +30,37 @@ import Text.Parsing.StringParser.String (string)
 
 -- | The authority part of a URI. For example: `purescript.org`,
 -- | `localhost:3000`, `user@example.net`
-data Authority = Authority (Maybe UserInfo) (Array (Tuple Host (Maybe Port)))
+data Authority userInfo = Authority (Maybe userInfo) (Array (Tuple Host (Maybe Port)))
 
-derive instance eqAuthority ∷ Eq Authority
-derive instance ordAuthority ∷ Ord Authority
-derive instance genericAuthority ∷ Generic Authority _
-instance showAuthority ∷ Show Authority where show = genericShow
+derive instance eqAuthority ∷ Eq userInfo ⇒ Eq (Authority userInfo)
+derive instance ordAuthority ∷ Ord userInfo ⇒ Ord (Authority userInfo)
+derive instance genericAuthority ∷ Generic (Authority userInfo) _
+instance showAuthority ∷ Show userInfo ⇒ Show (Authority userInfo) where show = genericShow
 
-parser ∷ Parser Authority
-parser = do
+parser ∷ ∀ userInfo. Parser userInfo → Parser (Authority userInfo)
+parser parseUserInfo = do
   _ ← string "//"
-  ui ← optionMaybe $ try (UserInfo.parser <* string "@")
+  ui ← optionMaybe $ try (UserInfo.parser' parseUserInfo <* string "@")
   hosts ← flip sepBy (string ",") $
     Tuple <$> Host.parser <*> optionMaybe (string ":" *> Port.parser)
   pure $ Authority ui (fromFoldable hosts)
 
-print ∷ Authority → String
-print (Authority ui hs) =
-  "//" <> printUserInfo <> S.joinWith "," (printHostAndPort <$> hs)
+print ∷ ∀ userInfo. (userInfo → String) → Authority userInfo → String
+print printUserInfo (Authority ui hs) =
+  "//" <> printUserInfo' ui <> S.joinWith "," (printHostAndPort <$> hs)
   where
-  printUserInfo =
-    maybe "" (\u → UserInfo.print u <> "@") ui
+  printUserInfo' =
+    maybe "" (\u → printUserInfo u <> "@")
   printHostAndPort (Tuple h p) =
     Host.print h <> maybe "" (\n → ":" <> Port.print n) p
 
-_userInfo ∷ Lens' Authority (Maybe UserInfo)
+_userInfo ∷ ∀ userInfo. Lens' (Authority userInfo) (Maybe userInfo)
 _userInfo =
   lens
     (\(Authority ui _) → ui)
     (\(Authority _ hs) ui → Authority ui hs)
 
-_hosts ∷ Lens' Authority (Array (Tuple Host (Maybe Port)))
+_hosts ∷ ∀ userInfo. Lens' (Authority userInfo) (Array (Tuple Host (Maybe Port)))
 _hosts =
   lens
     (\(Authority _ hs) → hs)

src/Data/URI/Fragment.purs

@@ -10,7 +10,7 @@ import Data.Newtype (class Newtype)
 import Data.String as S
 import Data.String.Regex as RX
 import Data.String.Regex.Flags as RXF
-import Data.URI.Common (decodePCTComponent, joinWith, parsePChar)
+import Data.URI.Common (decodePCTComponent, joinWith, parsePChar, wrapParser)
 import Global (encodeURIComponent)
 import Partial.Unsafe (unsafePartial)
 import Text.Parsing.StringParser (Parser)
@@ -26,11 +26,19 @@ derive instance genericFragment ∷ Generic Fragment _
 derive instance newtypeFragment ∷ Newtype Fragment _
 instance showFragment ∷ Show Fragment where show = genericShow
 
+parser' ∷ ∀ f. Parser f → Parser f
+parser' parseF = string "#" *>
+  wrapParser parseF (joinWith ""
+    <$> many (parsePChar decodePCTComponent <|> string "/" <|> string "?"))
+
 parser ∷ Parser Fragment
 parser = string "#" *>
   (Fragment <<< joinWith ""
     <$> many (parsePChar decodePCTComponent <|> string "/" <|> string "?"))
 
+print' ∷ ∀ f. (f → String) → f → String
+print' printF f = "#" <> printF f
+
 print ∷ Fragment → String
 print (Fragment f) =
   "#" <> S.joinWith "" (map printChar $ S.split (S.Pattern "") f)

src/Data/URI/HierarchicalPart.purs

@@ -5,7 +5,6 @@ module Data.URI.HierarchicalPart
   , _authority
   , _path
   , module Data.URI.Authority
-  , module Data.URI.Path
   ) where
 
 import Prelude
@@ -19,44 +18,47 @@ import Data.Maybe (Maybe(..))
 import Data.String as S
 import Data.URI.Authority (Authority(..), Host(..), Port(..), UserInfo(..), _IPv4Address, _IPv6Address, _NameAddress, _hosts, _userInfo)
 import Data.URI.Authority as Authority
-import Data.URI.Path (URIPath, URIPathAbs, URIPathRel)
 import Data.URI.Path as Path
 import Text.Parsing.StringParser (Parser)
 
 -- | The "hierarchical part" of a generic or absolute URI.
-data HierarchicalPart = HierarchicalPart (Maybe Authority) (Maybe URIPathAbs)
+data HierarchicalPart userInfo path = HierarchicalPart (Maybe (Authority userInfo)) (Maybe path)
 
-derive instance eqHierarchicalPart ∷ Eq HierarchicalPart
-derive instance ordHierarchicalPart ∷ Ord HierarchicalPart
-derive instance genericHierarchicalPart ∷ Generic HierarchicalPart _
-instance showHierarchicalPart ∷ Show HierarchicalPart where show = genericShow
+derive instance eqHierarchicalPart ∷ (Eq userInfo, Eq path) ⇒ Eq (HierarchicalPart userInfo path)
+derive instance ordHierarchicalPart ∷ (Ord userInfo, Ord path) ⇒ Ord (HierarchicalPart userInfo path)
+derive instance genericHierarchicalPart ∷ Generic (HierarchicalPart userInfo path) _
+instance showHierarchicalPart ∷ (Show userInfo, Show path) ⇒ Show (HierarchicalPart userInfo path) where show = genericShow
 
-parser ∷ Parser HierarchicalPart
-parser = withAuth <|> withoutAuth
+parser ∷ ∀ userInfo path. Parser userInfo → Parser path → Parser (HierarchicalPart userInfo path)
+parser parseUserInfo parsePath = withAuth <|> withoutAuth
   where
   withAuth =
     HierarchicalPart <<< Just
-      <$> Authority.parser
-      <*> Path.parsePathAbEmpty Path.parseURIPathAbs
+      <$> Authority.parser parseUserInfo
+      <*> Path.parsePathAbEmpty parsePath
 
   withoutAuth = HierarchicalPart Nothing <$> noAuthPath
 
   noAuthPath
-      = (Just <$> Path.parsePathAbsolute Path.parseURIPathAbs)
-    <|> (Just <$> Path.parsePathRootless Path.parseURIPathAbs)
+      = (Just <$> Path.parsePathAbsolute parsePath)
+    <|> (Just <$> Path.parsePathRootless parsePath)
     <|> pure Nothing
 
-print ∷ HierarchicalPart → String
-print (HierarchicalPart a p) =
-  S.joinWith "" (catMaybes [Authority.print <$> a, Path.printPath <$> p])
+print ∷ ∀ userInfo path. (userInfo → String) → (path → String) → HierarchicalPart userInfo path → String
+print printUserInfo printPath (HierarchicalPart a p) =
+  S.joinWith "" $
+    catMaybes
+      [ Authority.print printUserInfo <$> a
+      , printPath <$> p
+      ]
 
-_authority ∷ Lens' HierarchicalPart (Maybe Authority)
+_authority ∷ ∀ userInfo path. Lens' (HierarchicalPart userInfo path) (Maybe (Authority userInfo))
 _authority =
   lens
     (\(HierarchicalPart a _) → a)
     (\(HierarchicalPart _ p) a → HierarchicalPart a p)
 
-_path ∷ Lens' HierarchicalPart (Maybe URIPathAbs)
+_path ∷ ∀ userInfo path. Lens' (HierarchicalPart userInfo path) (Maybe path)
 _path =
   lens
     (\(HierarchicalPart _ p) → p)

src/Data/URI/Path.purs

@@ -25,8 +25,9 @@ import Data.String as Str
 import Data.URI.Common (PCTEncoded, decodePCT, joinWith, parsePCTEncoded, parsePChar, parseSubDelims, parseUnreserved, wrapParser)
 import Global (encodeURI)
 import Text.Parsing.StringParser (Parser(..), ParseError(..), try)
-import Text.Parsing.StringParser.Combinators (many, many1)
+import Text.Parsing.StringParser.Combinators (many, many1, optionMaybe)
 import Text.Parsing.StringParser.String (string)
+import Debug.Trace
 
 -- | A general URI path, can be used to represent relative or absolute paths
 -- | that are sandboxed or unsandboxed.
@@ -47,14 +48,14 @@ parsePath p
   <|> pure Nothing
 
 parsePathAbEmpty ∷ ∀ p. Parser p → Parser (Maybe p)
-parsePathAbEmpty p
-  = try (Just <$> wrapParser p
-      (joinWith "" <$> many (append <$> string "/" <*> parseSegment)))
-  <|> pure Nothing
+parsePathAbEmpty p =
+  optionMaybe $ wrapParser p do
+    parts ← many1 (string "/" *> parseSegment)
+    pure ("/" <> joinWith "/" parts)
 
 parsePathAbsolute ∷ ∀ p. Parser p → Parser p
 parsePathAbsolute p = wrapParser p $ do
-  _ <- string "/"
+  _ ← string "/"
   start ← parseSegmentNonZero
   rest ← joinWith "" <$> many (append <$> string "/" <*> parseSegment)
   pure $ "/" <> start <> rest

src/Data/URI/Query.purs

@@ -1,7 +1,9 @@
 module Data.URI.Query
   ( Query(..)
   , parser
+  , parser'
   , print
+  , print'
   ) where
 
 import Prelude
@@ -36,6 +38,9 @@ instance showQuery ∷ Show Query where show = genericShow
 derive newtype instance semigroupQuery ∷ Semigroup Query
 derive newtype instance monoidQuery ∷ Monoid Query
 
+parser' ∷ ∀ q. Parser q → Parser q
+parser' parseQ = string "?" *> (wrapParser parseQ (try (rxPat "[^#]*")))
+
 parser ∷ Parser Query
 parser = string "?" *> (Query <$> wrapParser parseParts (try (rxPat "[^#]*")))
 
@@ -48,6 +53,9 @@ parsePart = do
   value ← optionMaybe $ decodeURIComponent <$> (string "=" *> rxPat "[^;&]*")
   pure $ Tuple key value
 
+print' ∷ ∀ q. (q → String) → q → String
+print' printQ q = "?" <> printQ q
+
 print ∷ Query → String
 print (Query m) =
   case m of