-- |
--
-- Module      : Network.URI.Template.VarName
-- Copyright   : (c) 2025 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Network.URI.Template.VarName
  ( VarName
  , varNameP
  , varNamePretty
  , readVarName
  , unVarName
  ) where

import Prelude

import Data.Bifunctor (first)
import Data.String (IsString (..))
import Data.Text (Text, pack)
import Network.URI.Template.Internal.Parse
import Network.URI.Template.Internal.Pretty

newtype VarName = VarName
  { VarName -> Text
unwrap :: Text
  }
  deriving stock (VarName -> VarName -> Bool
(VarName -> VarName -> Bool)
-> (VarName -> VarName -> Bool) -> Eq VarName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VarName -> VarName -> Bool
== :: VarName -> VarName -> Bool
$c/= :: VarName -> VarName -> Bool
/= :: VarName -> VarName -> Bool
Eq, Eq VarName
Eq VarName =>
(VarName -> VarName -> Ordering)
-> (VarName -> VarName -> Bool)
-> (VarName -> VarName -> Bool)
-> (VarName -> VarName -> Bool)
-> (VarName -> VarName -> Bool)
-> (VarName -> VarName -> VarName)
-> (VarName -> VarName -> VarName)
-> Ord VarName
VarName -> VarName -> Bool
VarName -> VarName -> Ordering
VarName -> VarName -> VarName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: VarName -> VarName -> Ordering
compare :: VarName -> VarName -> Ordering
$c< :: VarName -> VarName -> Bool
< :: VarName -> VarName -> Bool
$c<= :: VarName -> VarName -> Bool
<= :: VarName -> VarName -> Bool
$c> :: VarName -> VarName -> Bool
> :: VarName -> VarName -> Bool
$c>= :: VarName -> VarName -> Bool
>= :: VarName -> VarName -> Bool
$cmax :: VarName -> VarName -> VarName
max :: VarName -> VarName -> VarName
$cmin :: VarName -> VarName -> VarName
min :: VarName -> VarName -> VarName
Ord, Int -> VarName -> ShowS
[VarName] -> ShowS
VarName -> String
(Int -> VarName -> ShowS)
-> (VarName -> String) -> ([VarName] -> ShowS) -> Show VarName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VarName -> ShowS
showsPrec :: Int -> VarName -> ShowS
$cshow :: VarName -> String
show :: VarName -> String
$cshowList :: [VarName] -> ShowS
showList :: [VarName] -> ShowS
Show)

instance IsString VarName where
  fromString :: String -> VarName
fromString = (String -> VarName)
-> (VarName -> VarName) -> Either String VarName -> VarName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> VarName
forall a. HasCallStack => String -> a
error VarName -> VarName
forall a. a -> a
id (Either String VarName -> VarName)
-> (String -> Either String VarName) -> String -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String VarName
readVarName

readVarName :: String -> Either String VarName
readVarName :: String -> Either String VarName
readVarName = (ParseError -> String)
-> Either ParseError VarName -> Either String VarName
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseError -> String
errorBundlePretty (Either ParseError VarName -> Either String VarName)
-> (String -> Either ParseError VarName)
-> String
-> Either String VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser VarName -> Text -> Either ParseError VarName
forall a. Parser a -> Text -> Either ParseError a
parse (Parser VarName
varNameP Parser VarName -> ParsecT Void Text Identity () -> Parser VarName
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) (Text -> Either ParseError VarName)
-> (String -> Text) -> String -> Either ParseError VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack

unVarName :: VarName -> Text
unVarName :: VarName -> Text
unVarName = (.unwrap)

-- |
--
-- @
-- varname       =  varchar *( ["."] varchar )
-- varchar       =  ALPHA / DIGIT / "_" / pct-encoded
-- @
varNameP :: Parser VarName
varNameP :: Parser VarName
varNameP = (Parser VarName -> String -> Parser VarName
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"variable name") (Parser VarName -> Parser VarName)
-> Parser VarName -> Parser VarName
forall a b. (a -> b) -> a -> b
$ do
  VarChar
v <- Parser VarChar
varCharP
  [(Maybe Char, VarChar)]
vs <- ParsecT Void Text Identity (Maybe Char, VarChar)
-> ParsecT Void Text Identity [(Maybe Char, VarChar)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity (Maybe Char, VarChar)
 -> ParsecT Void Text Identity [(Maybe Char, VarChar)])
-> ParsecT Void Text Identity (Maybe Char, VarChar)
-> ParsecT Void Text Identity [(Maybe Char, VarChar)]
forall a b. (a -> b) -> a -> b
$ (,) (Maybe Char -> VarChar -> (Maybe Char, VarChar))
-> ParsecT Void Text Identity (Maybe Char)
-> ParsecT Void Text Identity (VarChar -> (Maybe Char, VarChar))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (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 (VarChar -> (Maybe Char, VarChar))
-> Parser VarChar
-> ParsecT Void Text Identity (Maybe Char, VarChar)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser VarChar
varCharP

  VarName -> Parser VarName
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (VarName -> Parser VarName) -> VarName -> Parser VarName
forall a b. (a -> b) -> a -> b
$ Text -> VarName
VarName
    (Text -> VarName) -> Text -> VarName
forall a b. (a -> b) -> a -> b
$ ((Maybe Char, VarChar) -> Text) -> [(Maybe Char, VarChar)] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
      ( \case
          (Maybe Char
mc, VarChar Char
c) -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS -> (Char -> ShowS) -> Maybe Char -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id (:) Maybe Char
mc [Char
c]
          (Maybe Char
mc, PctEncoded String
s) -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS -> (Char -> ShowS) -> Maybe Char -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id (:) Maybe Char
mc String
s
      )
    ([(Maybe Char, VarChar)] -> Text)
-> [(Maybe Char, VarChar)] -> Text
forall a b. (a -> b) -> a -> b
$ (Maybe Char
forall a. Maybe a
Nothing, VarChar
v) (Maybe Char, VarChar)
-> [(Maybe Char, VarChar)] -> [(Maybe Char, VarChar)]
forall a. a -> [a] -> [a]
: [(Maybe Char, VarChar)]
vs

varNamePretty :: VarName -> Doc Ann
varNamePretty :: VarName -> Doc Ann
varNamePretty = Ann -> Doc Ann -> Doc Ann
forall ann. ann -> Doc ann -> Doc ann
annotate Ann
AnnVarName (Doc Ann -> Doc Ann) -> (VarName -> Doc Ann) -> VarName -> Doc Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty (Text -> Doc Ann) -> (VarName -> Text) -> VarName -> Doc Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Text
unVarName

data VarChar
  = VarChar Char
  | PctEncoded String

varCharP :: Parser VarChar
varCharP :: Parser VarChar
varCharP =
  [Parser VarChar] -> Parser VarChar
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Char -> VarChar
VarChar (Char -> VarChar)
-> ParsecT Void Text Identity Char -> Parser VarChar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
    , Char -> VarChar
VarChar (Char -> VarChar)
-> ParsecT Void Text Identity Char -> Parser VarChar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
'_'
    , String -> VarChar
PctEncoded (String -> VarChar)
-> ParsecT Void Text Identity String -> Parser VarChar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity String
pcntEncodedP
    ]
    Parser VarChar -> String -> Parser VarChar
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"variable character"

pcntEncodedP :: Parser String
pcntEncodedP :: ParsecT Void Text Identity String
pcntEncodedP =
  [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity String
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
    [ 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 Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
    , ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
    ]
    ParsecT Void Text Identity String
-> String -> ParsecT Void Text Identity String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"percent-encoded triplet"