{-# 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 qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
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
  RText 'Scheme
r <- String
-> (Text -> Maybe (RText 'Scheme)) -> m String -> m (RText 'Scheme)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"scheme" Text -> Maybe (RText 'Scheme)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
mkScheme (m String -> m (RText 'Scheme)) -> m String -> m (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ 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
'.')
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
  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
':')
  RText 'Scheme -> m (RText 'Scheme)
forall (m :: * -> *) a. Monad m => a -> m a
return RText 'Scheme
r
{-# 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 <- String
-> (Text -> Maybe (RText 'Host)) -> m String -> m (RText 'Host)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"host" Text -> Maybe (RText 'Host)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Host)
mkHost (Bool -> m String
forall e (m :: * -> *). MonadParsec e Text m => Bool -> m String
pHost Bool
True)
  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
-> (Text -> Maybe (RText 'Username))
-> m String
-> m (RText 'Username)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
      String
"username"
      Text -> Maybe (RText 'Username)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Username)
mkUsername
      ( String -> m String -> m String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"username" (m String -> m String) -> m String -> m String
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)
      )
  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
':')
    String
-> (Text -> Maybe (RText 'Password))
-> m String
-> m (RText 'Password)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
      String
"password"
      Text -> Maybe (RText 'Password)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Password)
mkPassword
      (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 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
'/')
  let mkPathPiece' :: Text -> Maybe (Maybe (RText 'PathPiece))
mkPathPiece' Text
x =
        if Text -> Bool
T.null Text
x
          then Maybe (RText 'PathPiece) -> Maybe (Maybe (RText 'PathPiece))
forall a. a -> Maybe a
Just Maybe (RText 'PathPiece)
forall a. Maybe a
Nothing
          else RText 'PathPiece -> Maybe (RText 'PathPiece)
forall a. a -> Maybe a
Just (RText 'PathPiece -> Maybe (RText 'PathPiece))
-> Maybe (RText 'PathPiece) -> Maybe (Maybe (RText 'PathPiece))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (RText 'PathPiece)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
mkPathPiece Text
x
  ([Maybe (RText 'PathPiece)]
maybePieces, Bool
trailingSlash) <- (StateT Bool m [Maybe (RText 'PathPiece)]
 -> Bool -> m ([Maybe (RText 'PathPiece)], Bool))
-> Bool
-> StateT Bool m [Maybe (RText 'PathPiece)]
-> m ([Maybe (RText 'PathPiece)], Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool m [Maybe (RText 'PathPiece)]
-> Bool -> m ([Maybe (RText 'PathPiece)], Bool)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
False (StateT Bool m [Maybe (RText 'PathPiece)]
 -> m ([Maybe (RText 'PathPiece)], Bool))
-> StateT Bool m [Maybe (RText 'PathPiece)]
-> m ([Maybe (RText 'PathPiece)], Bool)
forall a b. (a -> b) -> a -> b
$
    (StateT Bool m (Maybe (RText 'PathPiece))
 -> StateT Bool m Char -> StateT Bool m [Maybe (RText 'PathPiece)])
-> StateT Bool m Char
-> StateT Bool m (Maybe (RText 'PathPiece))
-> StateT Bool m [Maybe (RText 'PathPiece)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool m (Maybe (RText 'PathPiece))
-> StateT Bool m Char -> StateT Bool m [Maybe (RText 'PathPiece)]
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 (Maybe (RText 'PathPiece))
 -> StateT Bool m [Maybe (RText 'PathPiece)])
-> StateT Bool m (Maybe (RText 'PathPiece))
-> StateT Bool m [Maybe (RText 'PathPiece)]
forall a b. (a -> b) -> a -> b
$
      String
-> (Text -> Maybe (Maybe (RText 'PathPiece)))
-> StateT Bool m String
-> StateT Bool m (Maybe (RText 'PathPiece))
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"path piece" Text -> Maybe (Maybe (RText 'PathPiece))
mkPathPiece' (StateT Bool m String -> StateT Bool m (Maybe (RText 'PathPiece)))
-> StateT Bool m String -> StateT Bool m (Maybe (RText 'PathPiece))
forall a b. (a -> b) -> a -> b
$
        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
  let pieces :: [RText 'PathPiece]
pieces = [Maybe (RText 'PathPiece)] -> [RText 'PathPiece]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (RText 'PathPiece)]
maybePieces
  (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
'?')
    RText 'QueryKey
k <- String
-> (Text -> Maybe (RText 'QueryKey))
-> m String
-> m (RText 'QueryKey)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"query key" Text -> Maybe (RText 'QueryKey)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryKey)
mkQueryKey m String
p
    Maybe (RText 'QueryValue)
mv <- m (RText 'QueryValue) -> m (Maybe (RText 'QueryValue))
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 (RText 'QueryValue) -> m (RText 'QueryValue)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String
-> (Text -> Maybe (RText 'QueryValue))
-> m String
-> m (RText 'QueryValue)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"query value" Text -> Maybe (RText 'QueryValue)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryValue)
mkQueryValue m String
p)
    Maybe QueryParam -> m (Maybe QueryParam)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QueryParam -> m (Maybe QueryParam))
-> Maybe QueryParam -> m (Maybe QueryParam)
forall a b. (a -> b) -> a -> b
$
      if Text -> Bool
T.null (RText 'QueryKey -> Text
forall (l :: RTextLabel). RText l -> Text
unRText RText 'QueryKey
k)
        then Maybe QueryParam
forall a. Maybe a
Nothing
        else
          QueryParam -> Maybe QueryParam
forall a. a -> Maybe a
Just
            ( case Maybe (RText 'QueryValue)
mv of
                Maybe (RText 'QueryValue)
Nothing -> RText 'QueryKey -> QueryParam
QueryFlag RText 'QueryKey
k
                Just RText 'QueryValue
v -> RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
k RText 'QueryValue
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
-> (Text -> Maybe (RText 'Fragment))
-> m String
-> m (RText 'Fragment)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
    String
"fragment"
    Text -> Maybe (RText 'Fragment)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Fragment)
mkFragment
    ( 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
'?'
    )
{-# INLINE pFragment #-}

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

-- | Lift a smart constructor that consumes 'Text' into a parser.
liftR ::
  MonadParsec e Text m =>
  -- | What is being parsed
  String ->
  -- | The smart constructor that produces the result
  (Text -> Maybe r) ->
  -- | How to parse 'String' that will be converted to 'Text' and fed to
  -- the smart constructor
  m String ->
  m r
liftR :: String -> (Text -> Maybe r) -> m String -> m r
liftR String
lbl Text -> Maybe r
f m String
p = do
  Int
o <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  (Text
toks, String
s) <- m String -> m (Tokens Text, String)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match m String
p
  case ByteString -> Either UnicodeException Text
TE.decodeUtf8' (String -> ByteString
B8.pack String
s) of
    Left UnicodeException
_ -> do
      let unexp :: NonEmpty Char
unexp = String -> NonEmpty Char
forall a. [a] -> NonEmpty a
NE.fromList (Text -> String
T.unpack Text
toks)
          expecting :: NonEmpty Char
expecting = String -> NonEmpty Char
forall a. [a] -> NonEmpty a
NE.fromList (String
lbl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" that can be decoded as UTF-8")
      ParseError Text e -> m r
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError
        ( Int
-> Maybe (ErrorItem (Token Text))
-> Set (ErrorItem (Token Text))
-> ParseError Text e
forall s e.
Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
TrivialError
            Int
o
            (ErrorItem Char -> Maybe (ErrorItem Char)
forall a. a -> Maybe a
Just (NonEmpty Char -> ErrorItem Char
forall t. NonEmpty t -> ErrorItem t
Tokens NonEmpty Char
unexp))
            (ErrorItem Char -> Set (ErrorItem Char)
forall a. a -> Set a
S.singleton (NonEmpty Char -> ErrorItem Char
forall t. NonEmpty Char -> ErrorItem t
Label NonEmpty Char
expecting))
        )
    Right Text
text -> 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 (Text -> Maybe r
f Text
text)
{-# INLINE liftR #-}