{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_HADDOCK hide, prune #-}

module Symbolize.Accursed (accursedUnutterablePerformIO, utf8CompareByteArray#, shortTextFromBA, byteArrayStableNameHash##) where

import Data.Array.Byte (ByteArray (ByteArray))
import Data.ByteString.Short (ShortByteString (SBS))
import Data.Text.Short (ShortText)
import Data.Text.Short.Unsafe qualified as Text.Short.Unsafe
import GHC.Exts (ByteArray#, Int#, andI#, gtWord#, indexWord8Array#, isTrue#, ltWord#, makeStableName#, realWorld#, sizeofByteArray#, stableNameToInt#, word8ToWord#, (+#), (>=#))
import GHC.IO (IO (IO))

-- This \"function\" has a superficial similarity to 'System.IO.Unsafe.unsafePerformIO' but
-- it is in fact a malevolent agent of chaos.
--
-- Full warning: https://hackage.haskell.org/package/bytestring-0.12.0.2/docs/Data-ByteString-Internal.html#v:accursedUnutterablePerformIO
-- (This definition is also taken from there)
accursedUnutterablePerformIO :: IO a -> a
{-# INLINE accursedUnutterablePerformIO #-}
accursedUnutterablePerformIO :: forall a. IO a -> a
accursedUnutterablePerformIO (IO State# RealWorld -> (# State# RealWorld, a #)
m) = case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
realWorld# of (# State# RealWorld
_, a
r #) -> a
r

-- Lifted from `base`'s internal `GHC.Encoding.UTF8` module.
-- Since that module could change in any minor version bump,
-- the code is copied to here.
--
-- This special comparison is necessary since
-- normal comparison of `ByteArray`s is non-lexicographic.
utf8CompareByteArray# :: ByteArray# -> ByteArray# -> Ordering
{-# INLINE utf8CompareByteArray# #-}
utf8CompareByteArray# :: ByteArray# -> ByteArray# -> Ordering
utf8CompareByteArray# ByteArray#
a1 ByteArray#
a2 = Int# -> Int# -> Ordering
go Int#
0# Int#
0#
  where
    -- 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.

    !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 =
          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)
           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#)
                  Word#
_ -> case Word8# -> Word#
word8ToWord# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
a1 (Int#
off1 Int# -> Int# -> Int#
+# Int#
1#)) of
                    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
                  Word#
0xC0## -> case Word8# -> Word#
word8ToWord# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
a2 (Int#
off2 Int# -> Int# -> Int#
+# Int#
1#)) of
                    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#)

-- Helper function to go from ByteArray to ShortText.
-- Does *not* check whether it is valid UTF-8!
shortTextFromBA :: ByteArray -> ShortText
{-# INLINE shortTextFromBA #-}
shortTextFromBA :: ByteArray -> ShortText
shortTextFromBA (ByteArray ByteArray#
ba#) = ShortByteString -> ShortText
Text.Short.Unsafe.fromShortByteStringUnsafe (ByteArray# -> ShortByteString
SBS ByteArray#
ba#)

-- Calculate the stable name for an unlifted ByteArray#,
-- and immediately calculate its hash
byteArrayStableNameHash## :: ByteArray# -> Int#
{-# INLINE byteArrayStableNameHash## #-}
byteArrayStableNameHash## :: ByteArray# -> Int#
byteArrayStableNameHash## ByteArray#
ba# =
  case ByteArray#
-> State# RealWorld
-> (# State# RealWorld, StableName# ByteArray# #)
forall a.
a -> State# RealWorld -> (# State# RealWorld, StableName# a #)
makeStableName# ByteArray#
ba# State# RealWorld
realWorld# of
    (# State# RealWorld
_, StableName# ByteArray#
sname# #) -> StableName# ByteArray# -> Int#
forall a. StableName# a -> Int#
stableNameToInt# StableName# ByteArray#
sname#