{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}

-- |
-- Module      : Css3.Selector.Utils
-- Description : A set of utility methods to encode and decode strings.
-- Maintainer  : hapytexeu+gh@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- A module to encode and decode css selector strings. These are used in the parser and renderer to parse and render css selector strings.
module Css3.Selector.Utils
  ( -- * Identifiers
    readIdentifier,
    encodeIdentifier,
    isValidIdentifier,
    toIdentifier,

    -- * Css strings
    readCssString,
    encodeString,
    encodeText,
  )
where

import Control.Arrow (first)
import Data.Char (chr, digitToInt, intToDigit, isAsciiLower, isAsciiUpper, isHexDigit, ord)
#if __GLASGOW_HASKELL__ < 803
import Data.Semigroup((<>))
#endif
import Data.Text (Text, cons, pack, singleton, snoc)
import qualified Data.Text as T

_initLast :: [a] -> Maybe ([a], a)
_initLast :: forall a. [a] -> Maybe ([a], a)
_initLast [] = Maybe ([a], a)
forall a. Maybe a
Nothing
_initLast (a
a : [a]
as) = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> a -> ([a], a)
forall {a}. [a] -> a -> ([a], a)
go [a]
as a
a)
  where
    go :: [a] -> a -> ([a], a)
go [] a
x = ([], a
x)
    go (a
y : [a]
ys) a
x = ([a] -> [a]) -> ([a], a) -> ([a], a)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> a -> ([a], a)
go [a]
ys a
y)

_isQuote :: Char -> Bool
_isQuote :: Char -> Bool
_isQuote Char
'"' = Bool
True
_isQuote Char
'\'' = Bool
True
_isQuote Char
_ = Bool
False

-- | Parses a css string literal to a string that ontains the content of that
-- string literal.
readCssString ::
  -- | The string that contains the string literal in the css selector.
  String ->
  -- | A string that contains the content of the string literal.
  String
readCssString :: String -> String
readCssString (Char
c : String
xs) | Char -> Bool
_isQuote Char
c = String
f
  where
    f :: String
f
      | Just (String
vs, Char
c') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
_initLast String
xs = Char -> String -> String
g Char
c' String
vs
      | Bool
otherwise = String
"The string literal should contain at least two quotation marks."
      where
        g :: Char -> String -> String
g Char
c' String
vs
          | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' = Char -> String -> String
_readCssString Char
c String
vs
          | Bool
otherwise = String
"The start and end quotation mark should be the same."
readCssString String
_ = String -> String
forall a. HasCallStack => String -> a
error String
"The string should start with an \" or ' and end with the same quotation."

_readCssString :: Char -> String -> String
_readCssString :: Char -> String -> String
_readCssString Char
c' = String -> String
go
  where
    go :: String -> String
go [] = []
    go (Char
'\\' : Char
'\n' : String
xs) = String -> String
go String
xs
    go (Char
'\\' : ca :: String
ca@(Char
c : String
xs))
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
      | Bool
otherwise = let ~(Char
y, String
ys) = String -> (Char, String)
_parseEscape String
ca in Char
y Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
ys
    go (Char
x : String
xs)
      | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' = String -> String
forall a. HasCallStack => String -> a
error String
"The string can not contain a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", you should escape it."
      | Bool
otherwise = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs

-- | Parse a given css identifier to the content of the identifier.
readIdentifier ::
  -- | The given css identifier to parse.
  String ->
  -- | The result of the parsing: the content of the identifier.
  String
readIdentifier :: String -> String
readIdentifier = Char -> String -> String
_readCssString Char
'\\'

_notEncode :: Char -> Bool
_notEncode :: Char -> Bool
_notEncode Char
x = Char -> Bool
isAsciiLower Char
x Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
x

-- | Convert a string to a css selector string literal. This is done by putting
-- quotes around the content, and escaping certain characters.
encodeString ::
  -- | The type of quotes that should be put around the content (should be @'@ or @"@).
  Char ->
  -- | The string that should be converted to a css selector string literal.
  String ->
  -- | The corresponding css selector string literal.
  String
encodeString :: Char -> String -> String
encodeString Char
c' = (Char
c' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go
  where
    go :: String -> String
go [] = [Char
c']
    go (Char
c : String
cs)
      | Char -> Bool
_notEncode Char
c = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
cs
      | Bool
otherwise = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String -> String
_showHex (Char -> Int
ord Char
c) (String -> String
go String
cs)

-- | Convert a string to a css selector string literal. This is done by putting
-- quotes around the content, and escaping certain characters.
encodeText ::
  -- | The type of quotes that should be put around the content (should be @'@ or @"@).
  Char ->
  -- | The string that should be converted to a css selector string literal.
  Text ->
  -- | The corresponding css selector string literal.
  Text
encodeText :: Char -> Text -> Text
encodeText Char
c' Text
t = Char -> Text -> Text
cons Char
c' (Text -> Char -> Text
snoc ((Char -> Text) -> Text -> Text
T.concatMap Char -> Text
_encodeCharacter Text
t) Char
c')

_encodeCharacter :: Char -> Text
_encodeCharacter :: Char -> Text
_encodeCharacter Char
c
  | Char -> Bool
_notEncode Char
c = Char -> Text
singleton Char
c
  | Bool
otherwise = Char -> Text -> Text
cons Char
'\\' (String -> Text
pack (Int -> String -> String
_showHex (Char -> Int
ord Char
c) String
""))

-- | Encode a given identifier to its css selector equivalent by escaping
-- certain characters.
encodeIdentifier ::
  -- | The identifier to encode.
  Text ->
  -- | The encoded identifier.
  Text
encodeIdentifier :: Text -> Text
encodeIdentifier = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
_encodeCharacter

_showHex :: Int -> ShowS
_showHex :: Int -> String -> String
_showHex = Int -> Int -> String -> String
forall {t}. (Eq t, Num t) => t -> Int -> String -> String
go (Int
6 :: Int)
  where
    go :: t -> Int -> String -> String
go t
0 Int
_ String
s = String
s
    go t
k Int
n String
rs = t -> Int -> String -> String
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Int
q (Int -> Char
intToDigit Int
r Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs)
      where
        ~(Int
q, Int
r) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
quotRem Int
n Int
16

_parseEscape :: String -> (Char, String)
_parseEscape :: String -> (Char, String)
_parseEscape = Int -> Int -> String -> (Char, String)
forall {t}. (Eq t, Num t) => t -> Int -> String -> (Char, String)
go (Int
6 :: Int) Int
0
  where
    go :: t -> Int -> String -> (Char, String)
go t
0 Int
n String
cs = Int -> String -> (Char, String)
forall {b}. Int -> b -> (Char, b)
yield Int
n String
cs
    go t
_ Int
n String
"" = Int -> String -> (Char, String)
forall {b}. Int -> b -> (Char, b)
yield Int
n String
""
    go t
i Int
n ca :: String
ca@(Char
c : String
cs)
      | Char -> Bool
isHexDigit Char
c = t -> Int -> String -> (Char, String)
go (t
i t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
c) String
cs
      | Bool
otherwise = Int -> String -> (Char, String)
forall {b}. Int -> b -> (Char, b)
yield Int
n String
ca
    yield :: Int -> b -> (Char, b)
yield Int
n b
s = (Int -> Char
chr Int
n, b
s)

-- | Check if the given identifier is a valid css selector identifier.
isValidIdentifier ::
  -- | The given identifier to check.
  String ->
  -- | 'True' if the given identifier is valid, 'False' otherwise.
  Bool
isValidIdentifier :: String -> Bool
isValidIdentifier = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

-- | Convert the given string to a given object by first checking if it is a
-- valid identifier, and if not raising an error. If it is a valid identifier,
-- the string is packed, and wrapped in the given function.
toIdentifier ::
  -- | The given function to wrap the 'Text' identifier to an object.
  (Text -> a) ->
  -- | The string to validate, and wrap into the given function.
  String ->
  -- | The identifier object to return if the identifier is valid.
  a
toIdentifier :: forall a. (Text -> a) -> String -> a
toIdentifier Text -> a
f String
ident
  | String -> Bool
isValidIdentifier String
ident = Text -> a
f (String -> Text
pack String
ident)
  | Bool
otherwise = String -> a
forall a. HasCallStack => String -> a
error (String
"The identifier \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
ident String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" is not a valid identifier.")