-- |
-- 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.

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

module Text.URI.Parser.Text
  ( mkURI
  , parser )
where

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

-- | 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 input :: 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) "" Text
input of
    Left  b :: 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 x :: 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
  (absPath :: Bool
absPath, uriPath :: 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 {..}
{-# 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 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 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 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 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
xChar -> 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 "//")
  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 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 {..}
{-# 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 "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 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 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 Token Text
'@')
  UserInfo -> m UserInfo
forall (m :: * -> *) a. Monad m => a -> m a
return UserInfo :: RText 'Username -> Maybe (RText 'Password) -> UserInfo
UserInfo {..}
{-# 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 hasAuth :: 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 "//"))
  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) "//"
  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 Token Text
'/')
  (rawPieces :: [String]
rawPieces, trailingSlash :: 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 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 "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
        Nothing -> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. Maybe a
Nothing
        Just ps :: 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 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 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 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 "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 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 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 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
             Nothing -> QueryParam -> m QueryParam
forall (m :: * -> *) a. Monad m => a -> m a
return (RText 'QueryKey -> QueryParam
QueryFlag RText 'QueryKey
k)
             Just v :: 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 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 "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 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 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 f :: 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 #-}