-- | Implementation of double-X-encoder and -decoder in Haskell
{- ORMOLU_DISABLE -}

module DoubleXEncoding where

import Data.Function ((&))
import qualified Data.Text as T
import Data.Text (replace, Text)
import Data.Functor ((<&>))
import Distribution.Utils.Generic (isAsciiAlphaNum)
import Numeric (showHex, readHex)
import Data.Char (ord, isDigit, chr)
import Control.Monad (join)


-- | charEncode mapping in Haskell
charEncode :: Char -> Char
charEncode :: Char -> Char
charEncode = \case
  Char
' ' -> Char
'0'
  Char
'!' -> Char
'1'
  Char
'"' -> Char
'2'
  Char
'#' -> Char
'3'
  Char
'$' -> Char
'4'
  Char
'%' -> Char
'5'
  Char
'&' -> Char
'6'
  Char
'\'' -> Char
'7'
  Char
'(' -> Char
'8'
  Char
')' -> Char
'9'
  Char
'*' -> Char
'A'
  Char
'+' -> Char
'B'
  Char
',' -> Char
'C'
  Char
'-' -> Char
'D'
  Char
'.' -> Char
'E'
  Char
'/' -> Char
'F'

  Char
':' -> Char
'G'
  Char
';' -> Char
'H'
  Char
'<' -> Char
'I'
  Char
'=' -> Char
'J'
  Char
'>' -> Char
'K'
  Char
'?' -> Char
'L'
  Char
'@' -> Char
'M'

  Char
'[' -> Char
'N'
  Char
'\\' -> Char
'O'
  Char
']' -> Char
'P'
  Char
'^' -> Char
'Q'
  Char
'_' -> Char
'R'
  Char
'`' -> Char
'S'

  Char
'{' -> Char
'T'
  Char
'|' -> Char
'U'
  Char
'}' -> Char
'V'
  Char
'~' -> Char
'W'

  -- TODO: Remove this parsing workaround. Should be "X": "X"
  Char
'X' -> Char
'x'

  -- '': 'Z',  -- Reserved for encoding digits

  Char
_ -> Char
'\0'


charDecode :: Char -> Char
charDecode :: Char -> Char
charDecode = \case
  Char
'0' -> Char
' '
  Char
'1' -> Char
'!'
  Char
'2' -> Char
'"'
  Char
'3' -> Char
'#'
  Char
'4' -> Char
'$'
  Char
'5' -> Char
'%'
  Char
'6' -> Char
'&'
  Char
'7' -> Char
'\''
  Char
'8' -> Char
'('
  Char
'9' -> Char
')'
  Char
'A' -> Char
'*'
  Char
'B' -> Char
'+'
  Char
'C' -> Char
','
  Char
'D' -> Char
'-'
  Char
'E' -> Char
'.'
  Char
'F' -> Char
'/'

  Char
'G' -> Char
':'
  Char
'H' -> Char
';'
  Char
'I' -> Char
'<'
  Char
'J' -> Char
'='
  Char
'K' -> Char
'>'
  Char
'L' -> Char
'?'
  Char
'M' -> Char
'@'

  Char
'N' -> Char
'['
  Char
'O' -> Char
'\\'
  Char
'P' -> Char
']'
  Char
'Q' -> Char
'^'
  Char
'R' -> Char
'_'
  Char
'S' -> Char
'`'

  Char
'T' -> Char
'{'
  Char
'U' -> Char
'|'
  Char
'V' -> Char
'}'
  Char
'W' -> Char
'~'

  -- TODO: Remove this parsing workaround. Should be "X": "X"
  Char
'x' -> Char
'X'

  Char
_ -> Char
'\0'


hexShiftEncode :: Char -> Char
hexShiftEncode :: Char -> Char
hexShiftEncode = \case
  Char
'0' -> Char
'a'
  Char
'1' -> Char
'b'
  Char
'2' -> Char
'c'
  Char
'3' -> Char
'd'
  Char
'4' -> Char
'e'
  Char
'5' -> Char
'f'
  Char
'6' -> Char
'g'
  Char
'7' -> Char
'h'
  Char
'8' -> Char
'i'
  Char
'9' -> Char
'j'
  Char
'a' -> Char
'k'
  Char
'b' -> Char
'l'
  Char
'c' -> Char
'm'
  Char
'd' -> Char
'n'
  Char
'e' -> Char
'o'
  Char
'f' -> Char
'p'

  Char
_ -> Char
'\0'


hexShiftDecode :: Char -> Char
hexShiftDecode :: Char -> Char
hexShiftDecode = \case
  Char
'a' -> Char
'0'
  Char
'b' -> Char
'1'
  Char
'c' -> Char
'2'
  Char
'd' -> Char
'3'
  Char
'e' -> Char
'4'
  Char
'f' -> Char
'5'
  Char
'g' -> Char
'6'
  Char
'h' -> Char
'7'
  Char
'i' -> Char
'8'
  Char
'j' -> Char
'9'
  Char
'k' -> Char
'a'
  Char
'l' -> Char
'b'
  Char
'm' -> Char
'c'
  Char
'n' -> Char
'd'
  Char
'o' -> Char
'e'
  Char
'p' -> Char
'f'

  Char
_ -> Char
'\0'


data EncodeOptions = EncodeOptions
  { EncodeOptions -> Bool
encodeLeadingDigit :: Bool
  , EncodeOptions -> Bool
encodeDoubleUnderscore :: Bool
  }


doubleXEncodeWithOptions :: EncodeOptions -> Text -> Text
doubleXEncodeWithOptions :: EncodeOptions -> Text -> Text
doubleXEncodeWithOptions EncodeOptions
encodeOptions Text
text =
  let
    encodeStandard :: Text -> Text
encodeStandard Text
text = Text
text
      Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
"XX" Text
"XXXXXX"
      Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (\Text
txt ->
          if EncodeOptions
encodeOptionsEncodeOptions -> (EncodeOptions -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
&EncodeOptions -> Bool
encodeDoubleUnderscore
          then Text
txt Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
"__" Text
"XXRXXR"
          else Text
txt
        )
      Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
      String -> (Char -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\Char
char ->
            if Char -> Bool
isAsciiAlphaNum Char
char Bool -> Bool -> Bool
|| Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
            then [Char
char]
            else
              if Char -> Char
charEncode Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0'
              then [Char
'X', Char
'X', Char -> Char
charEncode Char
char]
              else
                let
                  charHex :: String
charHex = Int -> ShowS
forall a. Integral a => a -> ShowS
showHex (Char -> Int
ord Char
char) String
""
                  charHexEncoded :: String
charHexEncoded = String
charHex String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
hexShiftEncode
                  padStart :: Int -> ShowS
padStart Int
n String
txt = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
txt) Char
'a' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
txt
                in
                  if
                    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
charHex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
5 ->
                        String
"XX" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
padStart Int
5 String
charHexEncoded
                    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
charHex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 ->
                        String
"XXY" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
padStart Int
6 String
charHexEncoded
                    | Bool
otherwise ->
                        ShowS
forall a. HasCallStack => String -> a
error String
"ERROR: Hex encoding is too long"
          )
      [String] -> ([String] -> String) -> String
forall a b. a -> (a -> b) -> b
& [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
      String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack

    encodeDigit :: Char -> Text
encodeDigit Char
digit =
      String -> Text
T.pack [Char
'X', Char
'X', Char
'Z', Char
digit]
  in
    if EncodeOptions
encodeOptionsEncodeOptions -> (EncodeOptions -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
&EncodeOptions -> Bool
encodeLeadingDigit
    then
      case Text -> String
T.unpack Text
text of
        [] -> Text
""

        Char
leadingChar : String
rest  ->
          if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isDigit Char
leadingChar
          then Text -> Text
encodeStandard Text
text
          else
            if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
            then Char -> Text
encodeDigit Char
leadingChar
            else
              Char -> Text
encodeDigit Char
leadingChar
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EncodeOptions -> Text -> Text
doubleXEncodeWithOptions
                    EncodeOptions
encodeOptions { encodeLeadingDigit = False }
                    (String -> Text
T.pack String
rest)
    else
      Text -> Text
encodeStandard Text
text




defaultOptions :: EncodeOptions
defaultOptions :: EncodeOptions
defaultOptions = EncodeOptions
    { encodeLeadingDigit :: Bool
encodeLeadingDigit = Bool
False
    , encodeDoubleUnderscore :: Bool
encodeDoubleUnderscore = Bool
False
    }


doubleXEncode :: Text -> Text
doubleXEncode :: Text -> Text
doubleXEncode =
    EncodeOptions -> Text -> Text
doubleXEncodeWithOptions EncodeOptions
defaultOptions


gqlOptions :: EncodeOptions
gqlOptions :: EncodeOptions
gqlOptions = EncodeOptions
    { encodeLeadingDigit :: Bool
encodeLeadingDigit = Bool
True
    , encodeDoubleUnderscore :: Bool
encodeDoubleUnderscore = Bool
True
    }


doubleXEncodeGql :: Text -> Text
doubleXEncodeGql :: Text -> Text
doubleXEncodeGql =
    EncodeOptions -> Text -> Text
doubleXEncodeWithOptions EncodeOptions
gqlOptions


parseHex :: Text -> Int
parseHex :: Text -> Int
parseHex Text
text =
  case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
text) of
    [(Int
int, String
"")] -> Int
int
    [(Int, String)]
_ -> Int
0


doubleXDecode :: Text -> Text
doubleXDecode :: Text -> Text
doubleXDecode Text
text =
  let
    decodeWord :: Text -> (Text, Text)
    decodeWord :: Text -> (Text, Text)
decodeWord Text
word =
      let
        noXX :: Text
noXX = Int -> Text -> Text
T.drop Int
2 Text
word
        first :: Text
first = Int -> Text -> Text
T.take Int
1 Text
noXX
      in
        if  | Text
first Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
>= Text
"a" Bool -> Bool -> Bool
&& Text
first Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
<= Text
"p" ->
                (String -> Text
T.pack [
                    Text
noXX
                      Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
                      String -> ShowS -> String
forall a b. a -> (a -> b) -> b
& Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
5
                      String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
hexShiftDecode
                      String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack
                      Text -> (Text -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Text -> Int
parseHex
                      Int -> (Int -> Char) -> Char
forall a b. a -> (a -> b) -> b
& Int -> Char
chr
                  ]
                , Int -> Text -> Text
T.drop Int
5 Text
noXX
                )

            | Text
first Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"X" ->
                if Text
"XXXX" Text -> Text -> Bool
`T.isPrefixOf` Text
noXX
                then (Text
"XX", Int -> Text -> Text
T.drop Int
4 Text
noXX)
                else (Text
"X", Int -> Text -> Text
T.drop Int
1 Text
word)

            | Text
first Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Y" ->
                (String -> Text
T.pack [
                    Text
noXX
                      Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.drop Int
1  -- Remove the "Y"
                      Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
                      String -> ShowS -> String
forall a b. a -> (a -> b) -> b
& Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
6
                      String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
hexShiftDecode
                      String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack
                      Text -> (Text -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Text -> Int
parseHex
                      Int -> (Int -> Char) -> Char
forall a b. a -> (a -> b) -> b
& Int -> Char
chr
                  ]
                , Int -> Text -> Text
T.drop Int
7 Text
noXX
                )

            | Text
first Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Z" ->
                (Text
noXX
                    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.drop Int
1
                    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.take Int
1
                , Int -> Text -> Text
T.drop Int
2 Text
noXX
                )

            | Bool
otherwise ->
              (Text
noXX
                Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.take Int
1
                Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
                String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
charDecode
                String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack
              , Int -> Text -> Text
T.drop Int
1 Text
noXX
              )
  in
    Text
text
      Text -> (Text -> (Text, Text)) -> (Text, Text)
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"XX"
      (Text, Text) -> ((Text, Text) -> Text) -> Text
forall a b. a -> (a -> b) -> b
& \case
          (Text
"", Text
end) -> case Text -> (Text, Text)
decodeWord Text
end of
            (Text
decoded, Text
"") -> Text
decoded
            (Text
decoded, Text
rest) -> Text
decoded Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
doubleXDecode Text
rest
          (Text
start, Text
"") -> Text
start
          (Text
start, Text
end) -> Text
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
doubleXDecode Text
end