{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected. This module used to live in the `ghc`
-- package but has been moved to `ghc-boot` because the definition
-- of the package database (needed in both ghc and in ghc-pkg) lives in
-- `ghc-boot` and uses ShortText, which in turn depends on this module.

-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 1997-2006
--
-- Character encodings
--
-- -----------------------------------------------------------------------------

module GHC.Utils.Encoding (
        -- * UTF-8
        utf8DecodeCharAddr#,
        utf8PrevChar,
        utf8CharStart,
        utf8DecodeChar,
        utf8DecodeByteString,
        utf8UnconsByteString,
        utf8DecodeShortByteString,
        utf8CompareShortByteString,
        utf8DecodeStringLazy,
        utf8EncodeChar,
        utf8EncodeString,
        utf8EncodeStringPtr,
        utf8EncodeShortByteString,
        utf8EncodedLength,
        countUTF8Chars,

        -- * Z-encoding
        zEncodeString,
        zDecodeString,

        -- * Base62-encoding
        toBase62,
        toBase62Padded
  ) where

import Prelude

import Foreign
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Data.Char
import qualified Data.Char as Char
import Numeric
import GHC.IO
import GHC.ST

import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BS
import Data.ByteString.Short.Internal (ShortByteString(..))

import GHC.Exts

-- -----------------------------------------------------------------------------
-- UTF-8

-- We can't write the decoder as efficiently as we'd like without
-- resorting to unboxed extensions, unfortunately.  I tried to write
-- an IO version of this function, but GHC can't eliminate boxed
-- results from an IO-returning function.
--
-- We assume we can ignore overflow when parsing a multibyte character here.
-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences
-- before decoding them (see "GHC.Data.StringBuffer").

{-# INLINE utf8DecodeChar# #-}
utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)
utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)
utf8DecodeChar# Int# -> Word#
indexWord8# =
  let !ch0 :: Int#
ch0 = Word# -> Int#
word2Int# (Int# -> Word#
indexWord8# Int#
0#) in
  case () of
    ()
_ | Int# -> Bool
isTrue# (Int#
ch0 Int# -> Int# -> Int#
<=# Int#
0x7F#) -> (# Int# -> Char#
chr# Int#
ch0, Int#
1# #)

      | Int# -> Bool
isTrue# ((Int#
ch0 Int# -> Int# -> Int#
>=# Int#
0xC0#) Int# -> Int# -> Int#
`andI#` (Int#
ch0 Int# -> Int# -> Int#
<=# Int#
0xDF#)) ->
        let !ch1 :: Int#
ch1 = Word# -> Int#
word2Int# (Int# -> Word#
indexWord8# Int#
1#) in
        if Int# -> Bool
isTrue# ((Int#
ch1 Int# -> Int# -> Int#
<# Int#
0x80#) Int# -> Int# -> Int#
`orI#` (Int#
ch1 Int# -> Int# -> Int#
>=# Int#
0xC0#)) then Int# -> (# Char#, Int# #)
fail Int#
1# else
        (# Int# -> Char#
chr# (((Int#
ch0 Int# -> Int# -> Int#
-# Int#
0xC0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
6#) Int# -> Int# -> Int#
+#
                  (Int#
ch1 Int# -> Int# -> Int#
-# Int#
0x80#)),
           Int#
2# #)

      | Int# -> Bool
isTrue# ((Int#
ch0 Int# -> Int# -> Int#
>=# Int#
0xE0#) Int# -> Int# -> Int#
`andI#` (Int#
ch0 Int# -> Int# -> Int#
<=# Int#
0xEF#)) ->
        let !ch1 :: Int#
ch1 = Word# -> Int#
word2Int# (Int# -> Word#
indexWord8# Int#
1#) in
        if Int# -> Bool
isTrue# ((Int#
ch1 Int# -> Int# -> Int#
<# Int#
0x80#) Int# -> Int# -> Int#
`orI#` (Int#
ch1 Int# -> Int# -> Int#
>=# Int#
0xC0#)) then Int# -> (# Char#, Int# #)
fail Int#
1# else
        let !ch2 :: Int#
ch2 = Word# -> Int#
word2Int# (Int# -> Word#
indexWord8# Int#
2#) in
        if Int# -> Bool
isTrue# ((Int#
ch2 Int# -> Int# -> Int#
<# Int#
0x80#) Int# -> Int# -> Int#
`orI#` (Int#
ch2 Int# -> Int# -> Int#
>=# Int#
0xC0#)) then Int# -> (# Char#, Int# #)
fail Int#
2# else
        (# Int# -> Char#
chr# (((Int#
ch0 Int# -> Int# -> Int#
-# Int#
0xE0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
12#) Int# -> Int# -> Int#
+#
                 ((Int#
ch1 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
6#)  Int# -> Int# -> Int#
+#
                  (Int#
ch2 Int# -> Int# -> Int#
-# Int#
0x80#)),
           Int#
3# #)

     | Int# -> Bool
isTrue# ((Int#
ch0 Int# -> Int# -> Int#
>=# Int#
0xF0#) Int# -> Int# -> Int#
`andI#` (Int#
ch0 Int# -> Int# -> Int#
<=# Int#
0xF8#)) ->
        let !ch1 :: Int#
ch1 = Word# -> Int#
word2Int# (Int# -> Word#
indexWord8# Int#
1#) in
        if Int# -> Bool
isTrue# ((Int#
ch1 Int# -> Int# -> Int#
<# Int#
0x80#) Int# -> Int# -> Int#
`orI#` (Int#
ch1 Int# -> Int# -> Int#
>=# Int#
0xC0#)) then Int# -> (# Char#, Int# #)
fail Int#
1# else
        let !ch2 :: Int#
ch2 = Word# -> Int#
word2Int# (Int# -> Word#
indexWord8# Int#
2#) in
        if Int# -> Bool
isTrue# ((Int#
ch2 Int# -> Int# -> Int#
<# Int#
0x80#) Int# -> Int# -> Int#
`orI#` (Int#
ch2 Int# -> Int# -> Int#
>=# Int#
0xC0#)) then Int# -> (# Char#, Int# #)
fail Int#
2# else
        let !ch3 :: Int#
ch3 = Word# -> Int#
word2Int# (Int# -> Word#
indexWord8# Int#
3#) in
        if Int# -> Bool
isTrue# ((Int#
ch3 Int# -> Int# -> Int#
<# Int#
0x80#) Int# -> Int# -> Int#
`orI#` (Int#
ch3 Int# -> Int# -> Int#
>=# Int#
0xC0#)) then Int# -> (# Char#, Int# #)
fail Int#
3# else
        (# Int# -> Char#
chr# (((Int#
ch0 Int# -> Int# -> Int#
-# Int#
0xF0#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
18#) Int# -> Int# -> Int#
+#
                 ((Int#
ch1 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
12#) Int# -> Int# -> Int#
+#
                 ((Int#
ch2 Int# -> Int# -> Int#
-# Int#
0x80#) Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
6#)  Int# -> Int# -> Int#
+#
                  (Int#
ch3 Int# -> Int# -> Int#
-# Int#
0x80#)),
           Int#
4# #)

      | Bool
otherwise -> Int# -> (# Char#, Int# #)
fail Int#
1#
  where
        -- all invalid sequences end up here:
        fail :: Int# -> (# Char#, Int# #)
        fail :: Int# -> (# Char#, Int# #)
fail Int#
nBytes# = (# Char#
'\0'#, Int#
nBytes# #)
        -- '\xFFFD' would be the usual replacement character, but
        -- that's a valid symbol in Haskell, so will result in a
        -- confusing parse error later on.  Instead we use '\0' which
        -- will signal a lexer error immediately.

utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)
utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)
utf8DecodeCharAddr# Addr#
a# Int#
off# =
#if !MIN_VERSION_base(4,16,0)
    utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))
#else
    (Int# -> Word#) -> (# Char#, Int# #)
utf8DecodeChar# (\Int#
i# -> Word8# -> Word#
word8ToWord# (Addr# -> Int# -> Word8#
indexWord8OffAddr# Addr#
a# (Int#
i# Int# -> Int# -> Int#
+# Int#
off#)))
#endif

utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)
utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)
utf8DecodeCharByteArray# ByteArray#
ba# Int#
off# =
#if !MIN_VERSION_base(4,16,0)
    utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))
#else
    (Int# -> Word#) -> (# Char#, Int# #)
utf8DecodeChar# (\Int#
i# -> Word8# -> Word#
word8ToWord# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
ba# (Int#
i# Int# -> Int# -> Int#
+# Int#
off#)))
#endif


utf8DecodeChar :: Ptr Word8 -> (Char, Int)
utf8DecodeChar :: Ptr Word8 -> (Char, Int)
utf8DecodeChar !(Ptr Addr#
a#) =
  case Addr# -> Int# -> (# Char#, Int# #)
utf8DecodeCharAddr# Addr#
a# Int#
0# of
    (# Char#
c#, Int#
nBytes# #) -> ( Char# -> Char
C# Char#
c#, Int# -> Int
I# Int#
nBytes# )

-- UTF-8 is cleverly designed so that we can always figure out where
-- the start of the current character is, given any position in a
-- stream.  This function finds the start of the previous character,
-- assuming there *is* a previous character.
utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)
utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)
utf8PrevChar Ptr Word8
p = Ptr Word8 -> IO (Ptr Word8)
utf8CharStart (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (-Int
1))

utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)
utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)
utf8CharStart Ptr Word8
p = Ptr Word8 -> IO (Ptr Word8)
forall {b}. (Storable b, Ord b, Num b) => Ptr b -> IO (Ptr b)
go Ptr Word8
p
 where go :: Ptr b -> IO (Ptr b)
go Ptr b
p = do b
w <- Ptr b -> IO b
forall a. Storable a => Ptr a -> IO a
peek Ptr b
p
                 if b
w b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= b
0x80 Bool -> Bool -> Bool
&& b
w b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
0xC0
                        then Ptr b -> IO (Ptr b)
go (Ptr b
p Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (-Int
1))
                        else Ptr b -> IO (Ptr b)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr b
p

{-# INLINE utf8DecodeLazy# #-}
utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]
utf8DecodeLazy# :: IO () -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]
utf8DecodeLazy# IO ()
retain Int# -> (# Char#, Int# #)
decodeChar# Int#
len#
  = Int# -> IO [Char]
unpack Int#
0#
  where
    unpack :: Int# -> IO [Char]
unpack Int#
i#
        | Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
>=# Int#
len#) = IO ()
retain IO () -> IO [Char] -> IO [Char]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        | Bool
otherwise =
            case Int# -> (# Char#, Int# #)
decodeChar# Int#
i# of
              (# Char#
c#, Int#
nBytes# #) -> do
                [Char]
rest <- IO [Char] -> IO [Char]
forall a. IO a -> IO a
unsafeDupableInterleaveIO (IO [Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ Int# -> IO [Char]
unpack (Int#
i# Int# -> Int# -> Int#
+# Int#
nBytes#)
                [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return (Char# -> Char
C# Char#
c# Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
rest)

utf8DecodeByteString :: ByteString -> [Char]
utf8DecodeByteString :: ByteString -> [Char]
utf8DecodeByteString (BS.PS ForeignPtr Word8
fptr Int
offset Int
len)
  = ForeignPtr Word8 -> Int -> Int -> [Char]
utf8DecodeStringLazy ForeignPtr Word8
fptr Int
offset Int
len

utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)
utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)
utf8UnconsByteString (BS.PS ForeignPtr Word8
_ Int
_ Int
0) = Maybe (Char, ByteString)
forall a. Maybe a
Nothing
utf8UnconsByteString (BS.PS ForeignPtr Word8
fptr Int
offset Int
len)
  = IO (Maybe (Char, ByteString)) -> Maybe (Char, ByteString)
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe (Char, ByteString)) -> Maybe (Char, ByteString))
-> IO (Maybe (Char, ByteString)) -> Maybe (Char, ByteString)
forall a b. (a -> b) -> a -> b
$
      ForeignPtr Word8
-> (Ptr Word8 -> IO (Maybe (Char, ByteString)))
-> IO (Maybe (Char, ByteString))
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO (Maybe (Char, ByteString)))
 -> IO (Maybe (Char, ByteString)))
-> (Ptr Word8 -> IO (Maybe (Char, ByteString)))
-> IO (Maybe (Char, ByteString))
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
        let (Char
c,Int
n) = Ptr Word8 -> (Char, Int)
utf8DecodeChar (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset)
        Maybe (Char, ByteString) -> IO (Maybe (Char, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Char, ByteString) -> IO (Maybe (Char, ByteString)))
-> Maybe (Char, ByteString) -> IO (Maybe (Char, ByteString))
forall a b. (a -> b) -> a -> b
$ (Char, ByteString) -> Maybe (Char, ByteString)
forall a. a -> Maybe a
Just (Char
c, ForeignPtr Word8 -> Int -> Int -> ByteString
BS.PS ForeignPtr Word8
fptr (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n))

utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]
utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]
utf8DecodeStringLazy ForeignPtr Word8
fp Int
offset (I# Int#
len#)
  = IO [Char] -> [Char]
forall a. IO a -> a
unsafeDupablePerformIO (IO [Char] -> [Char]) -> IO [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ do
      let !(Ptr Addr#
a#) = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fp Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset
      IO () -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]
utf8DecodeLazy# (ForeignPtr Word8 -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr Word8
fp) (Addr# -> Int# -> (# Char#, Int# #)
utf8DecodeCharAddr# Addr#
a#) Int#
len#
-- Note that since utf8DecodeLazy# returns a thunk the lifetime of the
-- ForeignPtr actually needs to be longer than the lexical lifetime
-- withForeignPtr would provide here. That's why we use touchForeignPtr to
-- keep the fp alive until the last character has actually been decoded.

utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering
utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering
utf8CompareShortByteString (SBS ByteArray#
a1) (SBS ByteArray#
a2) = Int# -> Int# -> Ordering
go Int#
0# Int#
0#
   -- UTF-8 has the property that sorting by bytes values also sorts by
   -- code-points.
   -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property
   -- doesn't hold and we must explicitly check this case here.
   -- Note that decoding every code point would also work but it would be much
   -- more costly.
   where
       !sz1 :: Int#
sz1 = ByteArray# -> Int#
sizeofByteArray# ByteArray#
a1
       !sz2 :: Int#
sz2 = ByteArray# -> Int#
sizeofByteArray# ByteArray#
a2
       go :: Int# -> Int# -> Ordering
go Int#
off1 Int#
off2
         | Int# -> Bool
isTrue# ((Int#
off1 Int# -> Int# -> Int#
>=# Int#
sz1) Int# -> Int# -> Int#
`andI#` (Int#
off2 Int# -> Int# -> Int#
>=# Int#
sz2)) = Ordering
EQ
         | Int# -> Bool
isTrue# (Int#
off1 Int# -> Int# -> Int#
>=# Int#
sz1)                          = Ordering
LT
         | Int# -> Bool
isTrue# (Int#
off2 Int# -> Int# -> Int#
>=# Int#
sz2)                          = Ordering
GT
         | Bool
otherwise =
#if !MIN_VERSION_base(4,16,0)
               let !b1_1 = indexWord8Array# a1 off1
                   !b2_1 = indexWord8Array# a2 off2
#else
               let !b1_1 :: Word#
b1_1 = Word8# -> Word#
word8ToWord# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
a1 Int#
off1)
                   !b2_1 :: Word#
b2_1 = Word8# -> Word#
word8ToWord# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
a2 Int#
off2)
#endif
               in case Word#
b1_1 of
                  Word#
0xC0## -> case Word#
b2_1 of
                     Word#
0xC0## -> Int# -> Int# -> Ordering
go (Int#
off1 Int# -> Int# -> Int#
+# Int#
1#) (Int#
off2 Int# -> Int# -> Int#
+# Int#
1#)
#if !MIN_VERSION_base(4,16,0)
                     _      -> case indexWord8Array# a1 (off1 +# 1#) of
#else
                     Word#
_      -> case Word8# -> Word#
word8ToWord# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
a1 (Int#
off1 Int# -> Int# -> Int#
+# Int#
1#)) of
#endif
                        Word#
0x80## -> Ordering
LT
                        Word#
_      -> Int# -> Int# -> Ordering
go (Int#
off1 Int# -> Int# -> Int#
+# Int#
1#) (Int#
off2 Int# -> Int# -> Int#
+# Int#
1#)
                  Word#
_      -> case Word#
b2_1 of
#if !MIN_VERSION_base(4,16,0)
                     0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of
#else
                     Word#
0xC0## -> case Word8# -> Word#
word8ToWord# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
a2 (Int#
off2 Int# -> Int# -> Int#
+# Int#
1#)) of
#endif
                        Word#
0x80## -> Ordering
GT
                        Word#
_      -> Int# -> Int# -> Ordering
go (Int#
off1 Int# -> Int# -> Int#
+# Int#
1#) (Int#
off2 Int# -> Int# -> Int#
+# Int#
1#)
                     Word#
_   | Int# -> Bool
isTrue# (Word#
b1_1 Word# -> Word# -> Int#
`gtWord#` Word#
b2_1) -> Ordering
GT
                         | Int# -> Bool
isTrue# (Word#
b1_1 Word# -> Word# -> Int#
`ltWord#` Word#
b2_1) -> Ordering
LT
                         | Bool
otherwise                     -> Int# -> Int# -> Ordering
go (Int#
off1 Int# -> Int# -> Int#
+# Int#
1#) (Int#
off2 Int# -> Int# -> Int#
+# Int#
1#)

utf8DecodeShortByteString :: ShortByteString -> [Char]
utf8DecodeShortByteString :: ShortByteString -> [Char]
utf8DecodeShortByteString (SBS ByteArray#
ba#)
  = IO [Char] -> [Char]
forall a. IO a -> a
unsafeDupablePerformIO (IO [Char] -> [Char]) -> IO [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
      let len# :: Int#
len# = ByteArray# -> Int#
sizeofByteArray# ByteArray#
ba# in
      IO () -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]
utf8DecodeLazy# (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ByteArray# -> Int# -> (# Char#, Int# #)
utf8DecodeCharByteArray# ByteArray#
ba#) Int#
len#

countUTF8Chars :: ShortByteString -> IO Int
countUTF8Chars :: ShortByteString -> IO Int
countUTF8Chars (SBS ByteArray#
ba) = Int# -> Int# -> IO Int
forall {m :: * -> *}. Monad m => Int# -> Int# -> m Int
go Int#
0# Int#
0#
  where
    len# :: Int#
len# = ByteArray# -> Int#
sizeofByteArray# ByteArray#
ba
    go :: Int# -> Int# -> m Int
go Int#
i# Int#
n#
      | Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
>=# Int#
len#) =
          Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int# -> Int
I# Int#
n#)
      | Bool
otherwise = do
          case ByteArray# -> Int# -> (# Char#, Int# #)
utf8DecodeCharByteArray# ByteArray#
ba Int#
i# of
            (# Char#
_, Int#
nBytes# #) -> Int# -> Int# -> m Int
go (Int#
i# Int# -> Int# -> Int#
+# Int#
nBytes#) (Int#
n# Int# -> Int# -> Int#
+# Int#
1#)

{-# INLINE utf8EncodeChar #-}
utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s)
               -> Char -> ST s Int
utf8EncodeChar :: forall s.
(Int# -> Word8# -> State# s -> State# s) -> Char -> ST s Int
utf8EncodeChar Int# -> Word8# -> State# s -> State# s
write# Char
c =
  let x :: Word
x = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) in
  case () of
    ()
_ | Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
0 Bool -> Bool -> Bool
&& Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0x007f -> do
          Int -> Word -> ST s ()
write Int
0 Word
x
          Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
        -- NB. '\0' is encoded as '\xC0\x80', not '\0'.  This is so that we
        -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).
      | Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0x07ff -> do
          Int -> Word -> ST s ()
write Int
0 (Word
0xC0 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. ((Word
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x1F))
          Int -> Word -> ST s ()
write Int
1 (Word
0x80 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word
x Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3F))
          Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
2
      | Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0xffff -> do
          Int -> Word -> ST s ()
write Int
0 (Word
0xE0 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
12) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0F)
          Int -> Word -> ST s ()
write Int
1 (Word
0x80 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3F)
          Int -> Word -> ST s ()
write Int
2 (Word
0x80 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word
x Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3F))
          Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
3
      | Bool
otherwise -> do
          Int -> Word -> ST s ()
write Int
0 (Word
0xF0 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
18))
          Int -> Word -> ST s ()
write Int
1 (Word
0x80 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. ((Word
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
12) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3F))
          Int -> Word -> ST s ()
write Int
2 (Word
0x80 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. ((Word
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3F))
          Int -> Word -> ST s ()
write Int
3 (Word
0x80 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word
x Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3F))
          Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
4
  where
    {-# INLINE write #-}
    write :: Int -> Word -> ST s ()
write (I# Int#
off#) (W# Word#
c#) = STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (STRep s () -> ST s ()) -> STRep s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
#if !MIN_VERSION_base(4,16,0)
      case write# off# (narrowWord8# c#) s of
#else
      case Int# -> Word8# -> State# s -> State# s
write# Int#
off# (Word# -> Word8#
wordToWord8# Word#
c#) State# s
s of
#endif
        State# s
s -> (# State# s
s, () #)

utf8EncodeString :: String -> ByteString
utf8EncodeString :: [Char] -> ByteString
utf8EncodeString [Char]
s =
  IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
    let len :: Int
len = [Char] -> Int
utf8EncodedLength [Char]
s
    ForeignPtr Word8
buf <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
len
    ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
buf ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
      Ptr Word8 -> [Char] -> IO ()
utf8EncodeStringPtr Ptr Word8
ptr [Char]
s
      ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignPtr Word8 -> Int -> Int -> ByteString
BS.fromForeignPtr ForeignPtr Word8
buf Int
0 Int
len)

utf8EncodeStringPtr :: Ptr Word8 -> String -> IO ()
utf8EncodeStringPtr :: Ptr Word8 -> [Char] -> IO ()
utf8EncodeStringPtr (Ptr Addr#
a#) [Char]
str = Addr# -> [Char] -> IO ()
go Addr#
a# [Char]
str
  where go :: Addr# -> [Char] -> IO ()
go !Addr#
_   []   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go Addr#
a# (Char
c:[Char]
cs) = do
#if !MIN_VERSION_base(4,16,0)
          -- writeWord8OffAddr# was taking a Word#
          I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c
#else
          I# Int#
off# <- ST RealWorld Int -> IO Int
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld Int -> IO Int) -> ST RealWorld Int -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int# -> Word8# -> State# RealWorld -> State# RealWorld)
-> Char -> ST RealWorld Int
forall s.
(Int# -> Word8# -> State# s -> State# s) -> Char -> ST s Int
utf8EncodeChar (Addr# -> Int# -> Word8# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Int# -> Word8# -> State# d -> State# d
writeWord8OffAddr# Addr#
a#) Char
c
#endif
          Addr# -> [Char] -> IO ()
go (Addr#
a# Addr# -> Int# -> Addr#
`plusAddr#` Int#
off#) [Char]
cs

utf8EncodeShortByteString :: String -> IO ShortByteString
utf8EncodeShortByteString :: [Char] -> IO ShortByteString
utf8EncodeShortByteString [Char]
str = (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> IO ShortByteString
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ShortByteString #))
 -> IO ShortByteString)
-> (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> IO ShortByteString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case [Char] -> Int
utf8EncodedLength [Char]
str         of { I# Int#
len# ->
  case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
len# State# RealWorld
s          of { (# State# RealWorld
s, MutableByteArray# RealWorld
mba# #) ->
  case MutableByteArray# RealWorld -> Int# -> [Char] -> ST RealWorld ()
forall {s}. MutableByteArray# s -> Int# -> [Char] -> ST s ()
go MutableByteArray# RealWorld
mba# Int#
0# [Char]
str                of { ST STRep RealWorld ()
f_go ->
  case STRep RealWorld ()
f_go State# RealWorld
s                        of { (# State# RealWorld
s, () #) ->
  case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba# State# RealWorld
s of { (# State# RealWorld
s, ByteArray#
ba# #) ->
  (# State# RealWorld
s, ByteArray# -> ShortByteString
SBS ByteArray#
ba# #) }}}}}
  where
    go :: MutableByteArray# s -> Int# -> [Char] -> ST s ()
go MutableByteArray# s
_ Int#
_ [] = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go MutableByteArray# s
mba# Int#
i# (Char
c:[Char]
cs) = do
#if !MIN_VERSION_base(4,16,0)
      -- writeWord8Array# was taking a Word#
      I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c
#else
      I# Int#
off# <- (Int# -> Word8# -> State# s -> State# s) -> Char -> ST s Int
forall s.
(Int# -> Word8# -> State# s -> State# s) -> Char -> ST s Int
utf8EncodeChar (\Int#
j# -> MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s
forall d.
MutableByteArray# d -> Int# -> Word8# -> State# d -> State# d
writeWord8Array# MutableByteArray# s
mba# (Int#
i# Int# -> Int# -> Int#
+# Int#
j#)) Char
c
#endif
      MutableByteArray# s -> Int# -> [Char] -> ST s ()
go MutableByteArray# s
mba# (Int#
i# Int# -> Int# -> Int#
+# Int#
off#) [Char]
cs

utf8EncodedLength :: String -> Int
utf8EncodedLength :: [Char] -> Int
utf8EncodedLength [Char]
str = Int -> [Char] -> Int
forall {t}. Num t => t -> [Char] -> t
go Int
0 [Char]
str
  where go :: t -> [Char] -> t
go !t
n [] = t
n
        go t
n (Char
c:[Char]
cs)
          | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x007f = t -> [Char] -> t
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [Char]
cs
          | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x07ff = t -> [Char] -> t
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
2) [Char]
cs
          | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xffff = t -> [Char] -> t
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
3) [Char]
cs
          | Bool
otherwise       = t -> [Char] -> t
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
4) [Char]
cs

-- -----------------------------------------------------------------------------
-- Note [Z-Encoding]
-- ~~~~~~~~~~~~~~~~~

{-
This is the main name-encoding and decoding function.  It encodes any
string into a string that is acceptable as a C name.  This is done
right before we emit a symbol name into the compiled C or asm code.
Z-encoding of strings is cached in the FastString interface, so we
never encode the same string more than once.

The basic encoding scheme is this.

* Tuples (,,,) are coded as Z3T

* Alphabetic characters (upper and lower) and digits
        all translate to themselves;
        except 'Z', which translates to 'ZZ'
        and    'z', which translates to 'zz'
  We need both so that we can preserve the variable/tycon distinction

* Most other printable characters translate to 'zx' or 'Zx' for some
        alphabetic character x

* The others translate as 'znnnU' where 'nnn' is the decimal number
        of the character

        Before          After
        --------------------------
        Trak            Trak
        foo_wib         foozuwib
        >               zg
        >1              zg1
        foo#            foozh
        foo##           foozhzh
        foo##1          foozhzh1
        fooZ            fooZZ
        :+              ZCzp
        ()              Z0T     0-tuple
        (,,,,)          Z5T     5-tuple
        (# #)           Z1H     unboxed 1-tuple (note the space)
        (#,,,,#)        Z5H     unboxed 5-tuple
                (NB: There is no Z1T nor Z0H.)
-}

type UserString = String        -- As the user typed it
type EncodedString = String     -- Encoded form


zEncodeString :: UserString -> EncodedString
zEncodeString :: [Char] -> [Char]
zEncodeString [Char]
cs = case [Char] -> Maybe [Char]
maybe_tuple [Char]
cs of
                Just [Char]
n  -> [Char]
n            -- Tuples go to Z2T etc
                Maybe [Char]
Nothing -> [Char] -> [Char]
go [Char]
cs
          where
                go :: [Char] -> [Char]
go []     = []
                go (Char
c:[Char]
cs) = Char -> [Char]
encode_digit_ch Char
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
go' [Char]
cs
                go' :: [Char] -> [Char]
go' []     = []
                go' (Char
c:[Char]
cs) = Char -> [Char]
encode_ch Char
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
go' [Char]
cs

unencodedChar :: Char -> Bool   -- True for chars that don't need encoding
unencodedChar :: Char -> Bool
unencodedChar Char
'Z' = Bool
False
unencodedChar Char
'z' = Bool
False
unencodedChar Char
c   =  Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z'
                  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z'
                  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'

-- If a digit is at the start of a symbol then we need to encode it.
-- Otherwise package names like 9pH-0.1 give linker errors.
encode_digit_ch :: Char -> EncodedString
encode_digit_ch :: Char -> [Char]
encode_digit_ch Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Char -> [Char]
encode_as_unicode_char Char
c
encode_digit_ch Char
c | Bool
otherwise            = Char -> [Char]
encode_ch Char
c

encode_ch :: Char -> EncodedString
encode_ch :: Char -> [Char]
encode_ch Char
c | Char -> Bool
unencodedChar Char
c = [Char
c]     -- Common case first

-- Constructors
encode_ch Char
'('  = [Char]
"ZL"   -- Needed for things like (,), and (->)
encode_ch Char
')'  = [Char]
"ZR"   -- For symmetry with (
encode_ch Char
'['  = [Char]
"ZM"
encode_ch Char
']'  = [Char]
"ZN"
encode_ch Char
':'  = [Char]
"ZC"
encode_ch Char
'Z'  = [Char]
"ZZ"

-- Variables
encode_ch Char
'z'  = [Char]
"zz"
encode_ch Char
'&'  = [Char]
"za"
encode_ch Char
'|'  = [Char]
"zb"
encode_ch Char
'^'  = [Char]
"zc"
encode_ch Char
'$'  = [Char]
"zd"
encode_ch Char
'='  = [Char]
"ze"
encode_ch Char
'>'  = [Char]
"zg"
encode_ch Char
'#'  = [Char]
"zh"
encode_ch Char
'.'  = [Char]
"zi"
encode_ch Char
'<'  = [Char]
"zl"
encode_ch Char
'-'  = [Char]
"zm"
encode_ch Char
'!'  = [Char]
"zn"
encode_ch Char
'+'  = [Char]
"zp"
encode_ch Char
'\'' = [Char]
"zq"
encode_ch Char
'\\' = [Char]
"zr"
encode_ch Char
'/'  = [Char]
"zs"
encode_ch Char
'*'  = [Char]
"zt"
encode_ch Char
'_'  = [Char]
"zu"
encode_ch Char
'%'  = [Char]
"zv"
encode_ch Char
c    = Char -> [Char]
encode_as_unicode_char Char
c

encode_as_unicode_char :: Char -> EncodedString
encode_as_unicode_char :: Char -> [Char]
encode_as_unicode_char Char
c = Char
'z' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: if Char -> Bool
isDigit ([Char] -> Char
forall a. [a] -> a
head [Char]
hex_str) then [Char]
hex_str
                                                           else Char
'0'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
hex_str
  where hex_str :: [Char]
hex_str = Int -> [Char] -> [Char]
forall a. (Integral a, Show a) => a -> [Char] -> [Char]
showHex (Char -> Int
ord Char
c) [Char]
"U"
  -- ToDo: we could improve the encoding here in various ways.
  -- eg. strings of unicode characters come out as 'z1234Uz5678U', we
  -- could remove the 'U' in the middle (the 'z' works as a separator).

zDecodeString :: EncodedString -> UserString
zDecodeString :: [Char] -> [Char]
zDecodeString [] = []
zDecodeString (Char
'Z' : Char
d : [Char]
rest)
  | Char -> Bool
isDigit Char
d = Char -> [Char] -> [Char]
decode_tuple   Char
d [Char]
rest
  | Bool
otherwise = Char -> Char
decode_upper   Char
d Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
zDecodeString [Char]
rest
zDecodeString (Char
'z' : Char
d : [Char]
rest)
  | Char -> Bool
isDigit Char
d = Char -> [Char] -> [Char]
decode_num_esc Char
d [Char]
rest
  | Bool
otherwise = Char -> Char
decode_lower   Char
d Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
zDecodeString [Char]
rest
zDecodeString (Char
c   : [Char]
rest) = Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
zDecodeString [Char]
rest

decode_upper, decode_lower :: Char -> Char

decode_upper :: Char -> Char
decode_upper Char
'L' = Char
'('
decode_upper Char
'R' = Char
')'
decode_upper Char
'M' = Char
'['
decode_upper Char
'N' = Char
']'
decode_upper Char
'C' = Char
':'
decode_upper Char
'Z' = Char
'Z'
decode_upper Char
ch  = {-pprTrace "decode_upper" (char ch)-} Char
ch

decode_lower :: Char -> Char
decode_lower Char
'z' = Char
'z'
decode_lower Char
'a' = Char
'&'
decode_lower Char
'b' = Char
'|'
decode_lower Char
'c' = Char
'^'
decode_lower Char
'd' = Char
'$'
decode_lower Char
'e' = Char
'='
decode_lower Char
'g' = Char
'>'
decode_lower Char
'h' = Char
'#'
decode_lower Char
'i' = Char
'.'
decode_lower Char
'l' = Char
'<'
decode_lower Char
'm' = Char
'-'
decode_lower Char
'n' = Char
'!'
decode_lower Char
'p' = Char
'+'
decode_lower Char
'q' = Char
'\''
decode_lower Char
'r' = Char
'\\'
decode_lower Char
's' = Char
'/'
decode_lower Char
't' = Char
'*'
decode_lower Char
'u' = Char
'_'
decode_lower Char
'v' = Char
'%'
decode_lower Char
ch  = {-pprTrace "decode_lower" (char ch)-} Char
ch

-- Characters not having a specific code are coded as z224U (in hex)
decode_num_esc :: Char -> EncodedString -> UserString
decode_num_esc :: Char -> [Char] -> [Char]
decode_num_esc Char
d [Char]
rest
  = Int -> [Char] -> [Char]
go (Char -> Int
digitToInt Char
d) [Char]
rest
  where
    go :: Int -> [Char] -> [Char]
go Int
n (Char
c : [Char]
rest) | Char -> Bool
isHexDigit Char
c = Int -> [Char] -> [Char]
go (Int
16Int -> 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) [Char]
rest
    go Int
n (Char
'U' : [Char]
rest)           = Int -> Char
chr Int
n Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
zDecodeString [Char]
rest
    go Int
n [Char]
other = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char]
"decode_num_esc: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++  Char
' 'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
other)

decode_tuple :: Char -> EncodedString -> UserString
decode_tuple :: Char -> [Char] -> [Char]
decode_tuple Char
d [Char]
rest
  = Int -> [Char] -> [Char]
go (Char -> Int
digitToInt Char
d) [Char]
rest
  where
        -- NB. recurse back to zDecodeString after decoding the tuple, because
        -- the tuple might be embedded in a longer name.
    go :: Int -> [Char] -> [Char]
go Int
n (Char
c : [Char]
rest) | Char -> Bool
isDigit Char
c = Int -> [Char] -> [Char]
go (Int
10Int -> 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) [Char]
rest
    go Int
0 (Char
'T':[Char]
rest)     = [Char]
"()" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
zDecodeString [Char]
rest
    go Int
n (Char
'T':[Char]
rest)     = Char
'(' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
zDecodeString [Char]
rest
    go Int
1 (Char
'H':[Char]
rest)     = [Char]
"(# #)" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
zDecodeString [Char]
rest
    go Int
n (Char
'H':[Char]
rest)     = Char
'(' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'#' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"#)" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
zDecodeString [Char]
rest
    go Int
n [Char]
other = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char]
"decode_tuple: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
other)

{-
Tuples are encoded as
        Z3T or Z3H
for 3-tuples or unboxed 3-tuples respectively.  No other encoding starts
        Z<digit>

* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple)
  There are no unboxed 0-tuples.

* "()" is the tycon for a boxed 0-tuple.
  There are no boxed 1-tuples.
-}

maybe_tuple :: UserString -> Maybe EncodedString

maybe_tuple :: [Char] -> Maybe [Char]
maybe_tuple [Char]
"(# #)" = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just([Char]
"Z1H")
maybe_tuple (Char
'(' : Char
'#' : [Char]
cs) = case Int -> [Char] -> (Int, [Char])
count_commas (Int
0::Int) [Char]
cs of
                                 (Int
n, Char
'#' : Char
')' : [Char]
_) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Char
'Z' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Char]
"H")
                                 (Int, [Char])
_                  -> Maybe [Char]
forall a. Maybe a
Nothing
maybe_tuple [Char]
"()" = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just([Char]
"Z0T")
maybe_tuple (Char
'(' : [Char]
cs)       = case Int -> [Char] -> (Int, [Char])
count_commas (Int
0::Int) [Char]
cs of
                                 (Int
n, Char
')' : [Char]
_) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Char
'Z' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Char]
"T")
                                 (Int, [Char])
_            -> Maybe [Char]
forall a. Maybe a
Nothing
maybe_tuple [Char]
_                = Maybe [Char]
forall a. Maybe a
Nothing

count_commas :: Int -> String -> (Int, String)
count_commas :: Int -> [Char] -> (Int, [Char])
count_commas Int
n (Char
',' : [Char]
cs) = Int -> [Char] -> (Int, [Char])
count_commas (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Char]
cs
count_commas Int
n [Char]
cs         = (Int
n,[Char]
cs)


{-
************************************************************************
*                                                                      *
                        Base 62
*                                                                      *
************************************************************************

Note [Base 62 encoding 128-bit integers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Instead of base-62 encoding a single 128-bit integer
(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers
(2 * ceil(10.75) characters).  Luckily for us, it's the same number of
characters!
-}

--------------------------------------------------------------------------
-- Base 62

-- The base-62 code is based off of 'locators'
-- ((c) Operational Dynamics Consulting, BSD3 licensed)

-- | Size of a 64-bit word when written as a base-62 string
word64Base62Len :: Int
word64Base62Len :: Int
word64Base62Len = Int
11

-- | Converts a 64-bit word into a base-62 string
toBase62Padded :: Word64 -> String
toBase62Padded :: Word64 -> [Char]
toBase62Padded Word64
w = [Char]
pad [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str
  where
    pad :: [Char]
pad = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
len Char
'0'
    len :: Int
len = Int
word64Base62Len Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
str -- 11 == ceil(64 / lg 62)
    str :: [Char]
str = Word64 -> [Char]
toBase62 Word64
w

toBase62 :: Word64 -> String
toBase62 :: Word64 -> [Char]
toBase62 Word64
w = Word64 -> (Int -> Char) -> Word64 -> [Char] -> [Char]
forall a.
(Integral a, Show a) =>
a -> (Int -> Char) -> a -> [Char] -> [Char]
showIntAtBase Word64
62 Int -> Char
represent Word64
w [Char]
""
  where
    represent :: Int -> Char
    represent :: Int -> Char
represent Int
x
        | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 = Int -> Char
Char.chr (Int
48 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x)
        | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
36 = Int -> Char
Char.chr (Int
65 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)
        | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
62 = Int -> Char
Char.chr (Int
97 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
36)
        | Bool
otherwise = [Char] -> Char
forall a. HasCallStack => [Char] -> a
error [Char]
"represent (base 62): impossible!"