module Data.BCP47.Internal.Parser
  ( complete
  , asciiLetterDigit
  , asciiLetter
  , asciiDigit
  ) where

import Control.Applicative ((<|>))
import Control.Monad (void)
import Data.Char (ord)
import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec (Parsec, eof, lookAhead, noneOf, satisfy, (<?>))
import Text.Megaparsec.Char (char)

-- | Ensure a subtag extends to the next '-' or end of input
--
-- Used for subtags that can match some prefix of another subtag.
-- For example, a @'Script'@ or @'Region'@ can accidentally be parsed
-- from the prefix of a @'Variant'@
--
-- The alternative would be to use @'notFollowedBy'@ with knowledge of
-- the legal characters in the next valid subtag.
complete :: Parsec Void Text a -> Parsec Void Text a
complete :: forall a. Parsec Void Text a -> Parsec Void Text a
complete Parsec Void Text a
parser =
  Parsec Void Text a
parser Parsec Void Text a
-> ParsecT Void Text Identity () -> Parsec Void Text a
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 () -> ParsecT Void Text Identity ()
forall a. Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-') ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char]
[Token Text]
tagChars))

tagChars :: String
tagChars :: [Char]
tagChars = Char
'-' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char
'a' .. Char
'z'] [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char
'A' .. Char
'Z'] [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char
'0' .. Char
'9']
{-# NOINLINE tagChars #-}

-- | Parse a single case-insensitive ASCII letter or digit
asciiLetterDigit :: Parsec Void Text Char
asciiLetterDigit :: ParsecT Void Text Identity Char
asciiLetterDigit = (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isAsciiLetterDigit ParsecT Void Text Identity Char
-> [Char] -> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"ascii letter or digit"
 where
  isAsciiLetterDigit :: Char -> Bool
isAsciiLetterDigit Char
c = do
    let code :: Int
code = Char -> Int
ord Char
c
    Int -> Bool
isCodeAsciiUpper Int
code Bool -> Bool -> Bool
|| Int -> Bool
isCodeAsciiLower Int
code Bool -> Bool -> Bool
|| Int -> Bool
isCodeAsciiDigit Int
code
{-# INLINE asciiLetterDigit #-}

-- | Parse a single case-insensitive ASCII letter
asciiLetter :: Parsec Void Text Char
asciiLetter :: ParsecT Void Text Identity Char
asciiLetter = (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isAsciiLetter ParsecT Void Text Identity Char
-> [Char] -> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"ascii letter"
 where
  isAsciiLetter :: Char -> Bool
isAsciiLetter Char
c = do
    let code :: Int
code = Char -> Int
ord Char
c
    Int -> Bool
isCodeAsciiUpper Int
code Bool -> Bool -> Bool
|| Int -> Bool
isCodeAsciiLower Int
code
{-# INLINE asciiLetter #-}

-- | Parse a single ASCII digit
asciiDigit :: Parsec Void Text Char
asciiDigit :: ParsecT Void Text Identity Char
asciiDigit = (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Int -> Bool
isCodeAsciiDigit (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) ParsecT Void Text Identity Char
-> [Char] -> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"ascii digit"
{-# INLINE asciiDigit #-}

isCodeAsciiUpper :: Int -> Bool
isCodeAsciiUpper :: Int -> Bool
isCodeAsciiUpper Int
code = Char -> Int
ord Char
'A' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
'Z'
{-# INLINE isCodeAsciiUpper #-}

isCodeAsciiLower :: Int -> Bool
isCodeAsciiLower :: Int -> Bool
isCodeAsciiLower Int
code = Char -> Int
ord Char
'a' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
'z'
{-# INLINE isCodeAsciiLower #-}

isCodeAsciiDigit :: Int -> Bool
isCodeAsciiDigit :: Int -> Bool
isCodeAsciiDigit Int
code = Char -> Int
ord Char
'0' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
'9'
{-# INLINE isCodeAsciiDigit #-}