    {-# 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 :: forall (m :: * -> *). MonadThrow m => 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 a b.
    ParsecT Void Text Identity a
    -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    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 e a. (HasCallStack, Exception e) => e -> m a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, Exception e) =>
    e -> m a
    throwM (ParseErrorBundle Text Void -> ParseException
    ParseException ParseErrorBundle Text Void
    b)
        Right URI
    x -> URI -> m URI
    forall a. a -> m a
    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 :: forall e (m :: * -> *). MonadParsec e Text m => m URI
    parser = do
      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 a. m a -> m a
    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)
      mauth <- optional pAuthority
      (absPath, uriPath) <- pPath (isJust mauth)
      uriQuery <- option [] pQuery
      uriFragment <- optional pFragment
      let 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
      return URI {..}
    {-# INLINEABLE parser #-}
    {-# SPECIALIZE parser :: Parsec Void Text URI #-}

    pScheme :: (MonadParsec e Text m) => m (RText 'Scheme)
    pScheme :: forall e (m :: * -> *). MonadParsec e Text m => m (RText 'Scheme)
    pScheme = do
      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
        x <- m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    asciiAlphaChar
        xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.')
        return (x : xs)
      void (char ':')
      return r
    {-# INLINE pScheme #-}

    pAuthority :: (MonadParsec e Text m) => m Authority
    pAuthority :: forall e (m :: * -> *). MonadParsec e Text m => m Authority
    pAuthority = do
      m (Tokens 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
    "//")
      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
      authHost <- liftR "host" mkHost (pHost True)
      authPort <- optional (char ':' *> L.decimal)
      return Authority {..}
    {-# INLINE pAuthority #-}

    pUserInfo :: (MonadParsec e Text m) => m UserInfo
    pUserInfo :: forall e (m :: * -> *). MonadParsec e Text m => m UserInfo
    pUserInfo = m UserInfo -> m UserInfo
    forall a. m a -> m a
    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
      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 a. String -> m a -> m a
    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 a. m a -> m a -> m a
    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 a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    subDelimChar)
          )
      uiPassword <- optional $ do
        void (char ':')
        liftR
          "password"
          mkPassword
          (many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':'))
      void (char '@')
      return UserInfo {..}
    {-# INLINE pUserInfo #-}

    pPath ::
      (MonadParsec e Text m) =>
      Bool ->
      m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
    pPath :: forall e (m :: * -> *).
    MonadParsec e Text m =>
    Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
    pPath Bool
    hasAuth = do
      doubleSlash <- m Bool -> m Bool
    forall a. m a -> m a
    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 (Tokens Text) -> m Bool
    forall a b. a -> m b -> m a
    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
    "//"))
      when (doubleSlash && not hasAuth) $
        (unexpected . Tokens . NE.fromList) "//"
      absPath <- option False (True <$ char '/')
      let 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
      (maybePieces, trailingSlash) <- flip runStateT False $
        flip sepBy (char '/') $
          liftR "path piece" mkPathPiece' $
            label "path piece" $ do
              x <- many pchar
              put (null x)
              return x
      let pieces = [Maybe (RText 'PathPiece)] -> [RText 'PathPiece]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe (RText 'PathPiece)]
    maybePieces
      return
        ( absPath,
          case NE.nonEmpty 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 :: forall e (m :: * -> *). MonadParsec e Text m => 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 a b. (a -> b) -> m a -> m b
    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 a. String -> m a -> m a
    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 a. m a -> m a -> m a
    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 a. m a -> m a -> m a
    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
    '?')
        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
        mv <- optional (char '=' *> liftR "query value" mkQueryValue p)
        return $
          if T.null (unRText k)
            then Nothing
            else
              Just
                ( case 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 :: forall e (m :: * -> *). MonadParsec e Text m => 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 a. String -> m a -> m a
    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 a. m a -> m a -> m a
    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 a. m a -> m a -> m a
    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 :: forall e (m :: * -> *) r.
    MonadParsec e Text m =>
    String -> (Text -> Maybe r) -> m String -> m r
    liftR String
    lbl Text -> Maybe r
    f m String
    p = do
      o <- m Int
    forall e s (m :: * -> *). MonadParsec e s m => m Int
    getOffset
      (toks, s) <- match p
      case TE.decodeUtf8' (B8.pack s) of
        Left UnicodeException
    _ -> do
          let unexp :: NonEmpty Char
    unexp = String -> NonEmpty Char
    forall a. HasCallStack => [a] -> NonEmpty a
    NE.fromList (Text -> String
    T.unpack Text
    toks)
              expecting :: NonEmpty Char
    expecting = String -> NonEmpty Char
    forall a. HasCallStack => [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 a. ParseError Text e -> m a
    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 a. m a
    forall (f :: * -> *) a. Alternative f => f a
    empty r -> m r
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Text -> Maybe r
    f Text
    text)
    {-# INLINE liftR #-}