{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      :  Text.URI.Parser.Text
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- URI parser for strict 'Text', an internal module.
module Text.URI.Parser.Text
  ( mkURI,
    parser,
  )
where

import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.State.Strict
import qualified Data.ByteString.Char8 as B8
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes, isJust)
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.URI.Parser.Text.Utils
import Text.URI.Types

-- | Construct a 'URI' from 'Text'. The input you pass to 'mkURI' must be a
-- valid URI as per RFC 3986, that is, its components should be
-- percent-encoded where necessary. In case of parse failure
-- 'ParseException' is thrown.
--
-- This function uses the 'parser' parser under the hood, which you can also
-- use directly in a Megaparsec parser.
mkURI :: MonadThrow m => Text -> m URI
mkURI :: Text -> m URI
mkURI Text
input =
  case Parsec Void Text URI
-> String -> Text -> Either (ParseErrorBundle Text Void) URI
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void Text URI
forall e (m :: * -> *). MonadParsec e Text m => m URI
parser Parsec Void Text URI
-> ParsecT Void Text Identity () -> Parsec Void Text URI
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof :: Parsec Void Text URI) String
"" Text
input of
    Left ParseErrorBundle Text Void
b -> ParseException -> m URI
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseErrorBundle Text Void -> ParseException
ParseException ParseErrorBundle Text Void
b)
    Right URI
x -> URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI
x

-- | This parser can be used to parse 'URI' from strict 'Text'. Remember to
-- use a concrete non-polymorphic parser type for efficiency.
parser :: MonadParsec e Text m => m URI
parser :: m URI
parser = do
  Maybe (RText 'Scheme)
uriScheme <- m (RText 'Scheme) -> m (Maybe (RText 'Scheme))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m (RText 'Scheme) -> m (RText 'Scheme)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m (RText 'Scheme)
forall e (m :: * -> *). MonadParsec e Text m => m (RText 'Scheme)
pScheme)
  Maybe Authority
mauth <- m Authority -> m (Maybe Authority)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Authority
forall e (m :: * -> *). MonadParsec e Text m => m Authority
pAuthority
  (Bool
absPath, Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath) <- Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
forall e (m :: * -> *).
MonadParsec e Text m =>
Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
pPath (Maybe Authority -> Bool
forall a. Maybe a -> Bool
isJust Maybe Authority
mauth)
  [QueryParam]
uriQuery <- [QueryParam] -> m [QueryParam] -> m [QueryParam]
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option [] m [QueryParam]
forall e (m :: * -> *). MonadParsec e Text m => m [QueryParam]
pQuery
  Maybe (RText 'Fragment)
uriFragment <- m (RText 'Fragment) -> m (Maybe (RText 'Fragment))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m (RText 'Fragment)
forall e (m :: * -> *). MonadParsec e Text m => m (RText 'Fragment)
pFragment
  let uriAuthority :: Either Bool Authority
uriAuthority = Either Bool Authority
-> (Authority -> Either Bool Authority)
-> Maybe Authority
-> Either Bool Authority
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Either Bool Authority
forall a b. a -> Either a b
Left Bool
absPath) Authority -> Either Bool Authority
forall a b. b -> Either a b
Right Maybe Authority
mauth
  URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI :: Maybe (RText 'Scheme)
-> Either Bool Authority
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> [QueryParam]
-> Maybe (RText 'Fragment)
-> URI
URI {[QueryParam]
Maybe (Bool, NonEmpty (RText 'PathPiece))
Maybe (RText 'Scheme)
Maybe (RText 'Fragment)
Either Bool Authority
uriFragment :: Maybe (RText 'Fragment)
uriQuery :: [QueryParam]
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriAuthority :: Either Bool Authority
uriScheme :: Maybe (RText 'Scheme)
uriAuthority :: Either Bool Authority
uriFragment :: Maybe (RText 'Fragment)
uriQuery :: [QueryParam]
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriScheme :: Maybe (RText 'Scheme)
..}
{-# INLINEABLE parser #-}
{-# SPECIALIZE parser :: Parsec Void Text URI #-}

pScheme :: MonadParsec e Text m => m (RText 'Scheme)
pScheme :: m (RText 'Scheme)
pScheme = do
  Char
x <- m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
asciiAlphaChar
  String
xs <- m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
asciiAlphaNumChar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'+' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'.')
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':')
  (forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Scheme))
-> String -> m (RText 'Scheme)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Scheme)
mkScheme (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
{-# INLINE pScheme #-}

pAuthority :: MonadParsec e Text m => m Authority
pAuthority :: m Authority
pAuthority = do
  m Text -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens Text -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"//")
  Maybe UserInfo
authUserInfo <- m UserInfo -> m (Maybe UserInfo)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m UserInfo
forall e (m :: * -> *). MonadParsec e Text m => m UserInfo
pUserInfo
  RText 'Host
authHost <- Bool -> m String
forall e (m :: * -> *). MonadParsec e Text m => Bool -> m String
pHost Bool
True m String -> (String -> m (RText 'Host)) -> m (RText 'Host)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Host))
-> String -> m (RText 'Host)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Host)
mkHost
  Maybe Word
authPort <- m Word -> m (Maybe Word)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':' m Char -> m Word -> m Word
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Word
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal)
  Authority -> m Authority
forall (m :: * -> *) a. Monad m => a -> m a
return Authority :: Maybe UserInfo -> RText 'Host -> Maybe Word -> Authority
Authority {Maybe Word
Maybe UserInfo
RText 'Host
authPort :: Maybe Word
authHost :: RText 'Host
authUserInfo :: Maybe UserInfo
authPort :: Maybe Word
authHost :: RText 'Host
authUserInfo :: Maybe UserInfo
..}
{-# INLINE pAuthority #-}

pUserInfo :: MonadParsec e Text m => m UserInfo
pUserInfo :: m UserInfo
pUserInfo = m UserInfo -> m UserInfo
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (m UserInfo -> m UserInfo) -> m UserInfo -> m UserInfo
forall a b. (a -> b) -> a -> b
$ do
  RText 'Username
uiUsername <-
    String -> m (RText 'Username) -> m (RText 'Username)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"username" (m (RText 'Username) -> m (RText 'Username))
-> m (RText 'Username) -> m (RText 'Username)
forall a b. (a -> b) -> a -> b
$
      m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar)
        m String -> (String -> m (RText 'Username)) -> m (RText 'Username)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Username))
-> String -> m (RText 'Username)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Username)
mkUsername
  Maybe (RText 'Password)
uiPassword <- m (RText 'Password) -> m (Maybe (RText 'Password))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m (RText 'Password) -> m (Maybe (RText 'Password)))
-> m (RText 'Password) -> m (Maybe (RText 'Password))
forall a b. (a -> b) -> a -> b
$ do
    m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':')
    m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':')
      m String -> (String -> m (RText 'Password)) -> m (RText 'Password)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Password))
-> String -> m (RText 'Password)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Password)
mkPassword
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'@')
  UserInfo -> m UserInfo
forall (m :: * -> *) a. Monad m => a -> m a
return UserInfo :: RText 'Username -> Maybe (RText 'Password) -> UserInfo
UserInfo {Maybe (RText 'Password)
RText 'Username
uiPassword :: Maybe (RText 'Password)
uiUsername :: RText 'Username
uiPassword :: Maybe (RText 'Password)
uiUsername :: RText 'Username
..}
{-# INLINE pUserInfo #-}

pPath ::
  MonadParsec e Text m =>
  Bool ->
  m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
pPath :: Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
pPath Bool
hasAuth = do
  Bool
doubleSlash <- m Bool -> m Bool
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True Bool -> m Text -> m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"//"))
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
doubleSlash Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasAuth) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (ErrorItem Char -> m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ErrorItem (Token s) -> m a
unexpected (ErrorItem Char -> m ())
-> (String -> ErrorItem Char) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Char -> ErrorItem Char
forall t. NonEmpty t -> ErrorItem t
Tokens (NonEmpty Char -> ErrorItem Char)
-> (String -> NonEmpty Char) -> String -> ErrorItem Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NonEmpty Char
forall a. [a] -> NonEmpty a
NE.fromList) String
"//"
  Bool
absPath <- Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True Bool -> m Char -> m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/')
  ([String]
rawPieces, Bool
trailingSlash) <- (StateT Bool m [String] -> Bool -> m ([String], Bool))
-> Bool -> StateT Bool m [String] -> m ([String], Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool m [String] -> Bool -> m ([String], Bool)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
False (StateT Bool m [String] -> m ([String], Bool))
-> StateT Bool m [String] -> m ([String], Bool)
forall a b. (a -> b) -> a -> b
$
    (StateT Bool m String
 -> StateT Bool m Char -> StateT Bool m [String])
-> StateT Bool m Char
-> StateT Bool m String
-> StateT Bool m [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool m String
-> StateT Bool m Char -> StateT Bool m [String]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy (Token Text -> StateT Bool m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/') (StateT Bool m String -> StateT Bool m [String])
-> (StateT Bool m String -> StateT Bool m String)
-> StateT Bool m String
-> StateT Bool m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StateT Bool m String -> StateT Bool m String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"path piece" (StateT Bool m String -> StateT Bool m [String])
-> StateT Bool m String -> StateT Bool m [String]
forall a b. (a -> b) -> a -> b
$ do
      String
x <- StateT Bool m Char -> StateT Bool m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many StateT Bool m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar
      Bool -> StateT Bool m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x)
      String -> StateT Bool m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
  [RText 'PathPiece]
pieces <- (String -> m (RText 'PathPiece))
-> [String] -> m [RText 'PathPiece]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((forall (n :: * -> *).
 MonadThrow n =>
 Text -> n (RText 'PathPiece))
-> String -> m (RText 'PathPiece)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'PathPiece)
mkPathPiece) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
rawPieces)
  (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
-> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Bool
absPath,
      case [RText 'PathPiece] -> Maybe (NonEmpty (RText 'PathPiece))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [RText 'PathPiece]
pieces of
        Maybe (NonEmpty (RText 'PathPiece))
Nothing -> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. Maybe a
Nothing
        Just NonEmpty (RText 'PathPiece)
ps -> (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. a -> Maybe a
Just (Bool
trailingSlash, NonEmpty (RText 'PathPiece)
ps)
    )
{-# INLINE pPath #-}

pQuery :: MonadParsec e Text m => m [QueryParam]
pQuery :: m [QueryParam]
pQuery = do
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'?')
  m (Maybe Char) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'&'))
  ([Maybe QueryParam] -> [QueryParam])
-> m [Maybe QueryParam] -> m [QueryParam]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe QueryParam] -> [QueryParam]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe QueryParam] -> m [QueryParam])
-> (m (Maybe QueryParam) -> m [Maybe QueryParam])
-> m (Maybe QueryParam)
-> m [QueryParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (Maybe QueryParam) -> m Char -> m [Maybe QueryParam])
-> m Char -> m (Maybe QueryParam) -> m [Maybe QueryParam]
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Maybe QueryParam) -> m Char -> m [Maybe QueryParam]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'&') (m (Maybe QueryParam) -> m [Maybe QueryParam])
-> (m (Maybe QueryParam) -> m (Maybe QueryParam))
-> m (Maybe QueryParam)
-> m [Maybe QueryParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Maybe QueryParam) -> m (Maybe QueryParam)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"query parameter" (m (Maybe QueryParam) -> m [QueryParam])
-> m (Maybe QueryParam) -> m [QueryParam]
forall a b. (a -> b) -> a -> b
$ do
    let p :: m String
p = m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'?')
    String
k' <- m String
p
    Maybe String
mv <- m String -> m (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'=' m Char -> m String -> m String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m String
p)
    RText 'QueryKey
k <- (forall (n :: * -> *). MonadThrow n => Text -> n (RText 'QueryKey))
-> String -> m (RText 'QueryKey)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'QueryKey)
mkQueryKey String
k'
    if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
k'
      then Maybe QueryParam -> m (Maybe QueryParam)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QueryParam
forall a. Maybe a
Nothing
      else
        QueryParam -> Maybe QueryParam
forall a. a -> Maybe a
Just (QueryParam -> Maybe QueryParam)
-> m QueryParam -> m (Maybe QueryParam)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe String
mv of
          Maybe String
Nothing -> QueryParam -> m QueryParam
forall (m :: * -> *) a. Monad m => a -> m a
return (RText 'QueryKey -> QueryParam
QueryFlag RText 'QueryKey
k)
          Just String
v -> RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
k (RText 'QueryValue -> QueryParam)
-> m (RText 'QueryValue) -> m QueryParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (n :: * -> *).
 MonadThrow n =>
 Text -> n (RText 'QueryValue))
-> String -> m (RText 'QueryValue)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'QueryValue)
mkQueryValue String
v
{-# INLINE pQuery #-}

pFragment :: MonadParsec e Text m => m (RText 'Fragment)
pFragment :: m (RText 'Fragment)
pFragment = do
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'#')
  String
xs <-
    m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char -> m String) -> (m Char -> m Char) -> m Char -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Char -> m Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"fragment character" (m Char -> m String) -> m Char -> m String
forall a b. (a -> b) -> a -> b
$
      m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'?'
  (forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Fragment))
-> String -> m (RText 'Fragment)
forall e s (m :: * -> *) r.
MonadParsec e s m =>
(forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n (RText 'Fragment)
mkFragment String
xs
{-# INLINE pFragment #-}

----------------------------------------------------------------------------
-- Helpers

liftR ::
  MonadParsec e s m =>
  (forall n. MonadThrow n => Text -> n r) ->
  String ->
  m r
liftR :: (forall (n :: * -> *). MonadThrow n => Text -> n r)
-> String -> m r
liftR forall (n :: * -> *). MonadThrow n => Text -> n r
f = m r -> (r -> m r) -> Maybe r -> m r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m r
forall (f :: * -> *) a. Alternative f => f a
empty r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe r -> m r) -> (String -> Maybe r) -> String -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe r
forall (n :: * -> *). MonadThrow n => Text -> n r
f (Text -> Maybe r) -> (String -> Text) -> String -> Maybe r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> (String -> ByteString) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B8.pack
{-# INLINE liftR #-}