    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE OverloadedStrings #-}

    -- |
    -- Module      :  Text.URI.Parser.Text.Utils
    -- Copyright   :  © 2017–present Mark Karpov
    -- License     :  BSD 3 clause
    --
    -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- Random utilities for our 'Text' parsers.
    module Text.URI.Parser.Text.Utils
      ( pHost,
        asciiAlphaChar,
        asciiAlphaNumChar,
        unreservedChar,
        percentEncChar,
        subDelimChar,
        pchar,
        pchar',
      )
    where

    import Control.Monad
    import Data.Char
    import Data.List (intercalate)
    import qualified Data.List.NonEmpty as NE
    import Data.Maybe (maybeToList)
    import qualified Data.Set as E
    import Data.Text (Text)
    import qualified Data.Text as T
    import Text.Megaparsec
    import Text.Megaparsec.Char

    -- | Parser that can parse host names.
    pHost ::
      (MonadParsec e Text m) =>
      -- | Demand percent-encoding in reg names
      Bool ->
      m String
    pHost :: forall e (m :: * -> *). MonadParsec e Text m => Bool -> m String
    pHost Bool
    pe =
      [m String] -> m String
    forall (f :: * -> *) (m :: * -> *) a.
    (Foldable f, Alternative m) =>
    f (m a) -> m a
    choice
        [ m String -> m String
    forall a. m a -> m a
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
    try (m () -> m String
    forall e (m :: * -> *) a. MonadParsec e Text m => m a -> m String
    asConsumed m ()
    ipLiteral),
          m String
    regName
        ]
      where
        asConsumed :: (MonadParsec e Text m) => m a -> m String
        asConsumed :: forall e (m :: * -> *) a. MonadParsec e Text m => m a -> m String
    asConsumed m a
    p = Text -> String
    T.unpack (Text -> String) -> ((Text, a) -> Text) -> (Text, a) -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text, a) -> Text
    forall a b. (a, b) -> a
    fst ((Text, a) -> String) -> m (Text, a) -> m String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> m a -> m (Tokens Text, a)
    forall e s (m :: * -> *) a.
    MonadParsec e s m =>
    m a -> m (Tokens s, a)
    match m a
    p
        ipLiteral :: m ()
    ipLiteral =
          m Char -> m Char -> m () -> m ()
    forall (m :: * -> *) open close a.
    Applicative m =>
    m open -> m close -> m a -> m a
    between (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
    '[') (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 () -> m ()) -> m () -> m ()
    forall a b. (a -> b) -> a -> b
    $
            m () -> m ()
    forall a. m a -> m a
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
    try m ()
    ipv6Address m () -> m () -> m ()
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> m ()
    ipvFuture
        ipv6Address :: m ()
    ipv6Address = do
          pos <- m Int
    forall e s (m :: * -> *). MonadParsec e s m => m Int
    getOffset
          (toks, xs) <- match $ do
            xs' <- maybeToList <$> optional ([] <$ string "::")
            xs <- flip sepBy1 (char ':') $ do
              (skip, hasMore) <- lookAhead . hidden $ do
                skip <- option False (True <$ char ':')
                hasMore <- option False (True <$ hexDigitChar)
                return (skip, hasMore)
              case (skip, hasMore) of
                (Bool
    True, Bool
    True) -> String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                (Bool
    True, Bool
    False) -> [] String -> m Char -> m String
    forall a b. a -> m b -> m a
    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
    ':'
                (Bool
    False, Bool
    _) -> Int -> Int -> m Char -> m String
    forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
    count' Int
    1 Int
    4 m Char
    m (Token Text)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m (Token s)
    hexDigitChar
            return (xs' ++ xs)
          let nskips = [String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ((String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [String]
    xs)
              npieces = [String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    xs
          unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do
            setOffset pos
            failure
              (fmap Tokens . NE.nonEmpty . T.unpack $ toks)
              (E.singleton . Label . NE.fromList $ "valid IPv6 address")
        ipvFuture :: m ()
    ipvFuture = 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
    'v')
          m Char -> m ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void m Char
    m (Token Text)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m (Token s)
    hexDigitChar
          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 ()
    forall (m :: * -> *) a. MonadPlus m => m a -> m ()
    skipSome (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
    subDelimChar 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
    ':')
        regName :: m String
    regName = ([String] -> String) -> m [String] -> m String
    forall a b. (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ".") (m [String] -> m String)
    -> (m String -> m [String]) -> m String -> m String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (m String -> m Char -> m [String])
    -> m Char -> m String -> m [String]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip m String -> m Char -> m [String]
    forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
    sepBy1 (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 -> m String) -> m String -> m String
    forall a b. (a -> b) -> a -> b
    $ do
          m Char -> m String
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
    many (m Char -> m String) -> m Char -> m String
    forall a b. (a -> b) -> a -> b
    $
            if Bool
    pe
              then 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
    unreservedChar
              else m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    unreservedCharUnicode
    {-# INLINEABLE pHost #-}

    -- | Parse an ASCII alpha character.
    asciiAlphaChar :: (MonadParsec e Text m) => m Char
    asciiAlphaChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    asciiAlphaChar = (Token Text -> Bool) -> m (Token Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    (Token s -> Bool) -> m (Token s)
    satisfy Char -> Bool
    Token Text -> Bool
    isAsciiAlpha m Char -> String -> m Char
    forall e s (m :: * -> *) a.
    MonadParsec e s m =>
    m a -> String -> m a
    <?> String
    "ASCII alpha character"
    {-# INLINE asciiAlphaChar #-}

    -- | Parse an ASCII alpha-numeric character.
    asciiAlphaNumChar :: (MonadParsec e Text m) => m Char
    asciiAlphaNumChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    asciiAlphaNumChar = (Token Text -> Bool) -> m (Token Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    (Token s -> Bool) -> m (Token s)
    satisfy Char -> Bool
    Token Text -> Bool
    isAsciiAlphaNum m Char -> String -> m Char
    forall e s (m :: * -> *) a.
    MonadParsec e s m =>
    m a -> String -> m a
    <?> String
    "ASCII alpha-numeric character"
    {-# INLINE asciiAlphaNumChar #-}

    -- | Parse an unreserved character.
    unreservedChar :: (MonadParsec e Text m) => m Char
    unreservedChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    unreservedChar = 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
    "unreserved character" (m Char -> m Char)
    -> ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> m Char
    (Token Text -> Bool) -> m (Token Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    (Token s -> Bool) -> m (Token s)
    satisfy ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
    forall a b. (a -> b) -> a -> b
    $ \Char
    x ->
      Char -> Bool
    isAsciiAlphaNum Char
    x Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-' Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.' Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_' Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '~'
    {-# INLINE unreservedChar #-}

    -- | Parse an unreserved character allowing Unicode.
    unreservedCharUnicode :: (MonadParsec e Text m) => m Char
    unreservedCharUnicode :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    unreservedCharUnicode = 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
    "unreserved character" (m Char -> m Char)
    -> ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> m Char
    (Token Text -> Bool) -> m (Token Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    (Token s -> Bool) -> m (Token s)
    satisfy ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
    forall a b. (a -> b) -> a -> b
    $ \Char
    x ->
      Char -> Bool
    isAlphaNum Char
    x Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-' Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.' Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_' Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '~'
    {-# INLINE unreservedCharUnicode #-}

    -- | Parse a percent-encoded character.
    percentEncChar :: (MonadParsec e Text m) => m Char
    percentEncChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    percentEncChar = 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
    '%')
      h <- Char -> Int
    digitToInt (Char -> Int) -> m Char -> m Int
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> m Char
    m (Token Text)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m (Token s)
    hexDigitChar
      l <- digitToInt <$> hexDigitChar
      return . chr $ h * 16 + l
    {-# INLINE percentEncChar #-}

    -- | Parse a sub-delimiter character.
    subDelimChar :: (MonadParsec e Text m) => m Char
    subDelimChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    subDelimChar = Set (Token Text) -> m (Token Text)
    forall (f :: * -> *) e s (m :: * -> *).
    (Foldable f, MonadParsec e s m) =>
    f (Token s) -> m (Token s)
    oneOf Set Char
    Set (Token Text)
    s m Char -> String -> m Char
    forall e s (m :: * -> *) a.
    MonadParsec e s m =>
    m a -> String -> m a
    <?> String
    "sub-delimiter"
      where
        s :: Set Char
    s = String -> Set Char
    forall a. Ord a => [a] -> Set a
    E.fromList String
    "!$&'()*+,;="
    {-# INLINE subDelimChar #-}

    -- | PCHAR thing from the spec.
    pchar :: (MonadParsec e Text m) => m Char
    pchar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    pchar =
      [m Char] -> m Char
    forall (f :: * -> *) (m :: * -> *) a.
    (Foldable f, Alternative m) =>
    f (m a) -> m a
    choice
        [ m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    unreservedChar,
          m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    percentEncChar,
          m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    subDelimChar,
          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
    ':',
          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 pchar #-}

    -- | 'pchar' adjusted for query parsing.
    pchar' :: (MonadParsec e Text m) => m Char
    pchar' :: forall e (m :: * -> *). MonadParsec e Text m => m Char
    pchar' =
      [m Char] -> m Char
    forall (f :: * -> *) (m :: * -> *) a.
    (Foldable f, Alternative m) =>
    f (m a) -> m a
    choice
        [ m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    unreservedChar,
          m Char
    forall e (m :: * -> *). MonadParsec e Text m => m Char
    percentEncChar,
          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 b. m a -> m b -> m b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Char -> m Char
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Char
    ' ',
          Set (Token Text) -> m (Token Text)
    forall (f :: * -> *) e s (m :: * -> *).
    (Foldable f, MonadParsec e s m) =>
    f (Token s) -> m (Token s)
    oneOf Set Char
    Set (Token Text)
    s m Char -> String -> m Char
    forall e s (m :: * -> *) a.
    MonadParsec e s m =>
    m a -> String -> m a
    <?> String
    "sub-delimiter",
          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
    ':',
          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
    '@'
        ]
      where
        s :: Set Char
    s = String -> Set Char
    forall a. Ord a => [a] -> Set a
    E.fromList String
    "!$'()*,;"
    {-# INLINE pchar' #-}

    isAsciiAlpha :: Char -> Bool
    isAsciiAlpha :: Char -> Bool
    isAsciiAlpha Char
    x = Char -> Bool
    isAscii Char
    x Bool -> Bool -> Bool
    && Char -> Bool
    isAlpha Char
    x

    isAsciiAlphaNum :: Char -> Bool
    isAsciiAlphaNum :: Char -> Bool
    isAsciiAlphaNum Char
    x = Char -> Bool
    isAscii Char
    x Bool -> Bool -> Bool
    && Char -> Bool
    isAlphaNum Char
    x