{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
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
pHost ::
(MonadParsec e Text m) =>
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 :: (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' :: (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