{-# 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)
import Data.Text(Text, cons, pack, singleton, snoc)
import qualified Data.Text as T

_initLast :: [a] -> Maybe ([a], a)
_initLast :: [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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a
xa -> [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 :: String  -- ^ The string that contains the string literal in the css selector.
    -> String -- ^ A string that contains the content of the string literal.
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 :: String -- ^ The given css identifier to parse.
    -> String -- ^ The result of the parsing: the content of the identifier.
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 :: Char -- ^ The type of quotes that should be put around the content (should be @'@ or @"@).
    -> String -- ^ The string that should be converted to a css selector string literal.
    -> String -- ^ The corresponding css selector string literal.
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 :: Char -- ^ The type of quotes that should be put around the content (should be @'@ or @"@).
    -> Text -- ^ The string that should be converted to a css selector string literal.
    -> Text -- ^ The corresponding css selector string literal.
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 :: Text -- ^ The identifier to encode.
    -> Text -- ^ The encoded identifier.
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
kt -> 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
it -> t -> t
forall a. Num a => a -> a -> a
-t
1) (Int
16Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nInt -> 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 :: String  -- ^ The given identifier to check.
    -> Bool -- ^ 'True' if the given identifier is valid, 'False' otherwise.
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 (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 :: (Text -> a) -- ^ The given function to wrap the 'Text' identifier to an object.
    -> String -- ^ The string to validate, and wrap into the given function.
    -> a -- ^ The identifier object to return if the identifier is valid.
toIdentifier :: (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.")