{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UnliftedFFITypes         #-}

-- |
-- Module      :  System.OsPath.Data.ByteString.Short.Internal
-- Copyright   :  © 2022 Julian Ospald
-- License     :  MIT
--
-- Maintainer  :  Julian Ospald <hasufell@posteo.de>
-- Stability   :  experimental
-- Portability :  portable
--
-- Internal low-level utilities mostly for 'System.OsPath.Data.ByteString.Short.Word16',
-- such as byte-array operations and other stuff not meant to be exported from Word16 module.
module System.OsPath.Data.ByteString.Short.Internal where

import Control.Monad.ST
import Control.Exception (assert, throwIO)
import Data.Bits (Bits(..))
import Data.ByteString.Short.Internal (ShortByteString(..), length)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
  ( Semigroup((<>)) )
import Foreign.C.Types
  ( CSize(..)
  , CInt(..)
  )
import Data.ByteString.Internal
  ( accursedUnutterablePerformIO
  )
#endif
#if !MIN_VERSION_bytestring(0,10,9)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.C.String ( CString, CStringLen )
import Foreign.C.Types ( CSize(..) )
import Foreign.Storable (pokeByteOff)
#endif
import Foreign.Marshal.Array (withArray0, peekArray0, newArray0, withArrayLen, peekArray)
import GHC.Exts
import GHC.Word
import GHC.ST
    ( ST (ST) )
import GHC.Stack ( HasCallStack )
import Prelude hiding
    ( length )

import qualified Data.ByteString.Short.Internal as BS
import qualified Data.Char as C
import qualified Data.List as List


_nul :: Word16
_nul :: Word16
_nul = Word16
0x00

isSpace :: Word16 -> Bool
isSpace :: Word16 -> Bool
isSpace = Char -> Bool
C.isSpace (Char -> Bool) -> (Word16 -> Char) -> Word16 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Char
word16ToChar

-- | Total conversion to char.
word16ToChar :: Word16 -> Char
word16ToChar :: Word16 -> Char
word16ToChar = Int -> Char
C.chr (Int -> Char) -> (Word16 -> Int) -> Word16 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString
create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString
create Int
len forall s. MBA s -> ST s ()
fill =
    (forall s. ST s ShortByteString) -> ShortByteString
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s ShortByteString) -> ShortByteString)
-> (forall s. ST s ShortByteString) -> ShortByteString
forall a b. (a -> b) -> a -> b
$ do
      MBA s
mba <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
len
      MBA s -> ST s ()
forall s. MBA s -> ST s ()
fill MBA s
mba
      BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba
      ShortByteString -> ST s ShortByteString
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#)
{-# INLINE create #-}


asBA :: ShortByteString -> BA
asBA :: ShortByteString -> BA
asBA (SBS ByteArray#
ba#) = ByteArray# -> BA
BA# ByteArray#
ba#



data BA    = BA# ByteArray#
data MBA s = MBA# (MutableByteArray# s)


newPinnedByteArray :: Int -> ST s (MBA s)
newPinnedByteArray :: forall s. Int -> ST s (MBA s)
newPinnedByteArray (I# Int#
len#) =
    STRep s (MBA s) -> ST s (MBA s)
forall s a. STRep s a -> ST s a
ST (STRep s (MBA s) -> ST s (MBA s))
-> STRep s (MBA s) -> ST s (MBA s)
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case Int# -> State# s -> (# State# s, MutableByteArray# s #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
len# State# s
s of
                 (# State# s
s', MutableByteArray# s
mba# #) -> (# State# s
s', MutableByteArray# s -> MBA s
forall s. MutableByteArray# s -> MBA s
MBA# MutableByteArray# s
mba# #)

newByteArray :: Int -> ST s (MBA s)
newByteArray :: forall s. Int -> ST s (MBA s)
newByteArray (I# Int#
len#) =
    STRep s (MBA s) -> ST s (MBA s)
forall s a. STRep s a -> ST s a
ST (STRep s (MBA s) -> ST s (MBA s))
-> STRep s (MBA s) -> ST s (MBA s)
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case Int# -> State# s -> (# State# s, MutableByteArray# s #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
len# State# s
s of
                 (# State# s
s', MutableByteArray# s
mba# #) -> (# State# s
s', MutableByteArray# s -> MBA s
forall s. MutableByteArray# s -> MBA s
MBA# MutableByteArray# s
mba# #)

copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s ()
copyByteArray :: forall s. BA -> Int -> MBA s -> Int -> Int -> ST s ()
copyByteArray (BA# ByteArray#
src#) (I# Int#
src_off#) (MBA# MutableByteArray# s
dst#) (I# Int#
dst_off#) (I# Int#
len#) =
    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 -> case ByteArray#
-> Int#
-> MutableByteArray# s
-> Int#
-> Int#
-> State# s
-> State# s
forall d.
ByteArray#
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyByteArray# ByteArray#
src# Int#
src_off# MutableByteArray# s
dst# Int#
dst_off# Int#
len# State# s
s of
                 State# s
s' -> (# State# s
s', () #)

unsafeFreezeByteArray :: MBA s -> ST s BA
unsafeFreezeByteArray :: forall s. MBA s -> ST s BA
unsafeFreezeByteArray (MBA# MutableByteArray# s
mba#) =
    STRep s BA -> ST s BA
forall s a. STRep s a -> ST s a
ST (STRep s BA -> ST s BA) -> STRep s BA -> ST s BA
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# s
mba# State# s
s of
                 (# State# s
s', ByteArray#
ba# #) -> (# State# s
s', ByteArray# -> BA
BA# ByteArray#
ba# #)

copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
copyAddrToByteArray :: forall a. Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
copyAddrToByteArray (Ptr Addr#
src#) (MBA# MutableByteArray# RealWorld
dst#) (I# Int#
dst_off#) (I# Int#
len#) =
    STRep RealWorld () -> ST RealWorld ()
forall s a. STRep s a -> ST s a
ST (STRep RealWorld () -> ST RealWorld ())
-> STRep RealWorld () -> ST RealWorld ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Addr#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
src# MutableByteArray# RealWorld
dst# Int#
dst_off# Int#
len# State# RealWorld
s of
                 State# RealWorld
s' -> (# State# RealWorld
s', () #)


-- this is a copy-paste from bytestring
#if !MIN_VERSION_bytestring(0,10,9)
------------------------------------------------------------------------
-- Primop replacements

-- ---------------------------------------------------------------------
--
-- Standard C functions
--

foreign import ccall unsafe "string.h strlen" c_strlen
    :: CString -> IO CSize


-- ---------------------------------------------------------------------
--
-- Uses our C code
--

-- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The
-- resulting @ShortByteString@ is an immutable copy of the original
-- @CString@, and is managed on the Haskell heap. The original
-- @CString@ must be null terminated.
--
-- @since 0.10.10.0
packCString :: CString -> IO ShortByteString
packCString cstr = do
  len <- c_strlen cstr
  packCStringLen (cstr, fromIntegral len)

-- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The
-- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@.
-- The @ShortByteString@ is a normal Haskell value and will be managed on the
-- Haskell heap.
--
-- @since 0.10.10.0
packCStringLen :: CStringLen -> IO ShortByteString
packCStringLen (cstr, len) | len >= 0 = BS.createFromPtr cstr len
packCStringLen (_, len) =
  moduleErrorIO "packCStringLen" ("negative length: " ++ show len)

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a
-- null-terminated @CString@.  The @CString@ is a copy and will be freed
-- automatically; it must not be stored or used after the
-- subcomputation finishes.
--
-- @since 0.10.10.0
useAsCString :: ShortByteString -> (CString -> IO a) -> IO a
useAsCString bs action =
  allocaBytes (l+1) $ \buf -> do
      BS.copyToPtr bs 0 buf (fromIntegral l)
      pokeByteOff buf l (0::Word8)
      action buf
  where l = length bs

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CStringLen@.
-- As for @useAsCString@ this function makes a copy of the original @ShortByteString@.
-- It must not be stored or used after the subcomputation finishes.
--
-- @since 0.10.10.0
useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen bs action =
  allocaBytes l $ \buf -> do
      BS.copyToPtr bs 0 buf (fromIntegral l)
      action (buf, l)
  where l = length bs


#endif


-- | /O(n)./ Construct a new @ShortByteString@ from a @CWString@. The
-- resulting @ShortByteString@ is an immutable copy of the original
-- @CWString@, and is managed on the Haskell heap. The original
-- @CWString@ must be null terminated.
--
-- @since 0.10.10.0
packCWString :: Ptr Word16 -> IO ShortByteString
packCWString :: Ptr Word16 -> IO ShortByteString
packCWString Ptr Word16
cwstr = do
  [Word16]
cs <- Word16 -> Ptr Word16 -> IO [Word16]
forall a. (Storable a, Eq a) => a -> Ptr a -> IO [a]
peekArray0 Word16
_nul Ptr Word16
cwstr
  ShortByteString -> IO ShortByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word16] -> ShortByteString
packWord16 [Word16]
cs)

-- | /O(n)./ Construct a new @ShortByteString@ from a @CWStringLen@. The
-- resulting @ShortByteString@ is an immutable copy of the original @CWStringLen@.
-- The @ShortByteString@ is a normal Haskell value and will be managed on the
-- Haskell heap.
--
-- @since 0.10.10.0
packCWStringLen :: (Ptr Word16, Int) -> IO ShortByteString
packCWStringLen :: (Ptr Word16, Int) -> IO ShortByteString
packCWStringLen (Ptr Word16
cp, Int
len) = do
  [Word16]
cs <- Int -> Ptr Word16 -> IO [Word16]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
len Ptr Word16
cp
  ShortByteString -> IO ShortByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word16] -> ShortByteString
packWord16 [Word16]
cs)


-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a
-- null-terminated @CWString@.  The @CWString@ is a copy and will be freed
-- automatically; it must not be stored or used after the
-- subcomputation finishes.
--
-- @since 0.10.10.0
useAsCWString :: ShortByteString -> (Ptr Word16 -> IO a) -> IO a
useAsCWString :: forall a. ShortByteString -> (Ptr Word16 -> IO a) -> IO a
useAsCWString = Word16 -> [Word16] -> (Ptr Word16 -> IO a) -> IO a
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 Word16
_nul ([Word16] -> (Ptr Word16 -> IO a) -> IO a)
-> (ShortByteString -> [Word16])
-> ShortByteString
-> (Ptr Word16 -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> [Word16]
unpackWord16

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CWStringLen@.
-- As for @useAsCWString@ this function makes a copy of the original @ShortByteString@.
-- It must not be stored or used after the subcomputation finishes.
--
-- @since 0.10.10.0
useAsCWStringLen :: ShortByteString -> ((Ptr Word16, Int) -> IO a) -> IO a
useAsCWStringLen :: forall a. ShortByteString -> ((Ptr Word16, Int) -> IO a) -> IO a
useAsCWStringLen ShortByteString
bs (Ptr Word16, Int) -> IO a
action = [Word16] -> (Int -> Ptr Word16 -> IO a) -> IO a
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen (ShortByteString -> [Word16]
unpackWord16 ShortByteString
bs) ((Int -> Ptr Word16 -> IO a) -> IO a)
-> (Int -> Ptr Word16 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ Int
len Ptr Word16
ptr -> (Ptr Word16, Int) -> IO a
action (Ptr Word16
ptr, Int
len)

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CWStringLen@.
-- As for @useAsCWString@ this function makes a copy of the original @ShortByteString@.
-- It must not be stored or used after the subcomputation finishes.
--
-- @since 0.10.10.0
newCWString :: ShortByteString -> IO (Ptr Word16)
newCWString :: ShortByteString -> IO (Ptr Word16)
newCWString = Word16 -> [Word16] -> IO (Ptr Word16)
forall a. Storable a => a -> [a] -> IO (Ptr a)
newArray0 Word16
_nul ([Word16] -> IO (Ptr Word16))
-> (ShortByteString -> [Word16])
-> ShortByteString
-> IO (Ptr Word16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> [Word16]
unpackWord16




 -- ---------------------------------------------------------------------
-- Internal utilities

moduleErrorIO :: String -> String -> IO a
moduleErrorIO :: forall a. [Char] -> [Char] -> IO a
moduleErrorIO [Char]
fun [Char]
msg = IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO a) -> ([Char] -> IOError) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IOError
userError ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
moduleErrorMsg [Char]
fun [Char]
msg
{-# NOINLINE moduleErrorIO #-}

moduleErrorMsg :: String -> String -> String
moduleErrorMsg :: [Char] -> [Char] -> [Char]
moduleErrorMsg [Char]
fun [Char]
msg = [Char]
"System.OsPath.Data.ByteString.Short." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fun [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
' 'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
msg

packWord16 :: [Word16] -> ShortByteString
packWord16 :: [Word16] -> ShortByteString
packWord16 [Word16]
cs = Int -> [Word16] -> ShortByteString
packLenWord16 ([Word16] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Word16]
cs) [Word16]
cs

packLenWord16 :: Int -> [Word16] -> ShortByteString
packLenWord16 :: Int -> [Word16] -> ShortByteString
packLenWord16 Int
len [Word16]
ws0 =
    Int -> (forall s. MBA s -> ST s ()) -> ShortByteString
create (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) (\MBA s
mba -> MBA s -> Int -> [Word16] -> ST s ()
forall s. MBA s -> Int -> [Word16] -> ST s ()
go MBA s
mba Int
0 [Word16]
ws0)
  where
    go :: MBA s -> Int -> [Word16] -> ST s ()
    go :: forall s. MBA s -> Int -> [Word16] -> ST s ()
go !MBA s
_   !Int
_ []     = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go !MBA s
mba !Int
i (Word16
w:[Word16]
ws) = do
      MBA s -> Int -> Word16 -> ST s ()
forall s. MBA s -> Int -> Word16 -> ST s ()
writeWord16Array MBA s
mba Int
i Word16
w
      MBA s -> Int -> [Word16] -> ST s ()
forall s. MBA s -> Int -> [Word16] -> ST s ()
go MBA s
mba (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) [Word16]
ws


unpackWord16 :: ShortByteString -> [Word16]
unpackWord16 :: ShortByteString -> [Word16]
unpackWord16 ShortByteString
sbs = Int -> [Word16] -> [Word16]
go Int
len []
  where
    len :: Int
len = ShortByteString -> Int
length ShortByteString
sbs
    go :: Int -> [Word16] -> [Word16]
go !Int
i ![Word16]
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1     = [Word16]
acc
      | Bool
otherwise = let !w :: Word16
w = BA -> Int -> Word16
indexWord16Array (ShortByteString -> BA
asBA ShortByteString
sbs) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
                    in Int -> [Word16] -> [Word16]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) (Word16
wWord16 -> [Word16] -> [Word16]
forall a. a -> [a] -> [a]
:[Word16]
acc)

packWord16Rev :: [Word16] -> ShortByteString
packWord16Rev :: [Word16] -> ShortByteString
packWord16Rev [Word16]
cs = Int -> [Word16] -> ShortByteString
packLenWord16Rev ([Word16] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Word16]
cs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) [Word16]
cs

packLenWord16Rev :: Int -> [Word16] -> ShortByteString
packLenWord16Rev :: Int -> [Word16] -> ShortByteString
packLenWord16Rev Int
len [Word16]
ws0 =
    Int -> (forall s. MBA s -> ST s ()) -> ShortByteString
create Int
len (\MBA s
mba -> MBA s -> Int -> [Word16] -> ST s ()
forall s. MBA s -> Int -> [Word16] -> ST s ()
go MBA s
mba Int
len [Word16]
ws0)
  where
    go :: MBA s -> Int -> [Word16] -> ST s ()
    go :: forall s. MBA s -> Int -> [Word16] -> ST s ()
go !MBA s
_   !Int
_ []     = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go !MBA s
mba !Int
i (Word16
w:[Word16]
ws) = do
      MBA s -> Int -> Word16 -> ST s ()
forall s. MBA s -> Int -> Word16 -> ST s ()
writeWord16Array MBA s
mba (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Word16
w
      MBA s -> Int -> [Word16] -> ST s ()
forall s. MBA s -> Int -> [Word16] -> ST s ()
go MBA s
mba (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [Word16]
ws


-- | This isn't strictly Word16 array write. Instead it's two consecutive Word8 array
-- writes to avoid endianness issues due to primops doing automatic alignment based
-- on host platform. We want to always write LE to the byte array.
writeWord16Array :: MBA s
                 -> Int      -- ^ Word8 index (not Word16)
                 -> Word16
                 -> ST s ()
writeWord16Array :: forall s. MBA s -> Int -> Word16 -> ST s ()
writeWord16Array (MBA# MutableByteArray# s
mba#) (I# Int#
i#) (W16# Word16#
w#) =
  case Word16# -> (# Word8#, Word8# #)
encodeWord16LE# Word16#
w# of
    (# Word8#
lsb#, Word8#
msb# #) ->
      STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (\State# s
s -> case MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s
forall d.
MutableByteArray# d -> Int# -> Word8# -> State# d -> State# d
writeWord8Array# MutableByteArray# s
mba# Int#
i# Word8#
lsb# State# s
s of
          State# s
s' -> (# State# s
s', () #)) ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (\State# s
s -> case 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#
1#) Word8#
msb# State# s
s of
          State# s
s' -> (# State# s
s', () #))

indexWord8Array :: BA
                -> Int      -- ^ Word8 index
                -> Word8
indexWord8Array :: BA -> Int -> Word8
indexWord8Array (BA# ByteArray#
ba#) (I# Int#
i#) = Word8# -> Word8
W8# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
ba# Int#
i#)

-- | This isn't strictly Word16 array read. Instead it's two Word8 array reads
-- to avoid endianness issues due to primops doing automatic alignment based
-- on host platform. We expect the byte array to be LE always.
indexWord16Array :: BA
                 -> Int      -- ^ Word8 index (not Word16)
                 -> Word16
indexWord16Array :: BA -> Int -> Word16
indexWord16Array BA
ba Int
i = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lsb Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
msb Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
  where
    lsb :: Word8
lsb = BA -> Int -> Word8
indexWord8Array BA
ba Int
i
    msb :: Word8
msb = BA -> Int -> Word8
indexWord8Array BA
ba (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

#if !MIN_VERSION_base(4,16,0)

encodeWord16LE# :: Word#              -- ^ Word16
                -> (# Word#, Word# #) -- ^ Word8 (LSB, MSB)
encodeWord16LE# x# = (# x# `and#` int2Word# 0xff#
                     ,  x# `and#` int2Word# 0xff00# `shiftRL#` 8# #)

decodeWord16LE# :: (# Word#, Word# #) -- ^ Word8 (LSB, MSB)
                -> Word#              -- ^ Word16
decodeWord16LE# (# lsb#, msb# #) = msb# `shiftL#` 8# `or#` lsb#

#else

encodeWord16LE# :: Word16#              -- ^ Word16
                -> (# Word8#, Word8# #) -- ^ Word8 (LSB, MSB)
encodeWord16LE# :: Word16# -> (# Word8#, Word8# #)
encodeWord16LE# Word16#
x# = (# Word16# -> Word8#
word16ToWord8# Word16#
x#
                     ,  Word16# -> Word8#
word16ToWord8# (Word16#
x# Word16# -> Int# -> Word16#
`uncheckedShiftRLWord16#` Int#
8#) #)
  where
    word16ToWord8# :: Word16# -> Word8#
word16ToWord8# Word16#
y = Word# -> Word8#
wordToWord8# (Word16# -> Word#
word16ToWord# Word16#
y)

decodeWord16LE# :: (# Word8#, Word8# #) -- ^ Word8 (LSB, MSB)
                -> Word16#              -- ^ Word16
decodeWord16LE# :: (# Word8#, Word8# #) -> Word16#
decodeWord16LE# (# Word8#
lsb#, Word8#
msb# #) = ((Word8# -> Word16#
word8ToWord16# Word8#
msb# Word16# -> Int# -> Word16#
`uncheckedShiftLWord16#` Int#
8#) Word16# -> Word16# -> Word16#
`orWord16#` Word8# -> Word16#
word8ToWord16# Word8#
lsb#)
  where
    word8ToWord16# :: Word8# -> Word16#
word8ToWord16# Word8#
y = Word# -> Word16#
wordToWord16# (Word8# -> Word#
word8ToWord# Word8#
y)

#endif

setByteArray :: MBA s -> Int -> Int -> Int -> ST s ()
setByteArray :: forall s. MBA s -> Int -> Int -> Int -> ST s ()
setByteArray (MBA# MutableByteArray# s
dst#) (I# Int#
off#) (I# Int#
len#) (I# Int#
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 -> case MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s
forall d.
MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
setByteArray# MutableByteArray# s
dst# Int#
off# Int#
len# Int#
c# State# s
s of
                 State# s
s' -> (# State# s
s', () #)

copyMutableByteArray :: MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
copyMutableByteArray :: forall s. MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
copyMutableByteArray (MBA# MutableByteArray# s
src#) (I# Int#
src_off#) (MBA# MutableByteArray# s
dst#) (I# Int#
dst_off#) (I# Int#
len#) =
    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 -> case MutableByteArray# s
-> Int#
-> MutableByteArray# s
-> Int#
-> Int#
-> State# s
-> State# s
forall d.
MutableByteArray# d
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyMutableByteArray# MutableByteArray# s
src# Int#
src_off# MutableByteArray# s
dst# Int#
dst_off# Int#
len# State# s
s of
                 State# s
s' -> (# State# s
s', () #)

-- | Given the maximum size needed and a function to make the contents
-- of a ShortByteString, createAndTrim makes the 'ShortByteString'.
-- The generating function is required to return the actual final size
-- (<= the maximum size) and the result value. The resulting byte array
-- is realloced to this size.
createAndTrim :: Int -> (forall s. MBA s -> ST s (Int, a)) -> (ShortByteString, a)
createAndTrim :: forall a.
Int -> (forall s. MBA s -> ST s (Int, a)) -> (ShortByteString, a)
createAndTrim Int
l forall s. MBA s -> ST s (Int, a)
fill =
    (forall s. ST s (ShortByteString, a)) -> (ShortByteString, a)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (ShortByteString, a)) -> (ShortByteString, a))
-> (forall s. ST s (ShortByteString, a)) -> (ShortByteString, a)
forall a b. (a -> b) -> a -> b
$ do
      MBA s
mba <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
l
      (Int
l', a
res) <- MBA s -> ST s (Int, a)
forall s. MBA s -> ST s (Int, a)
fill MBA s
mba
      if Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l
          then do
            BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba
            (ShortByteString, a) -> ST s (ShortByteString, a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#, a
res)
          else do
            MBA s
mba2 <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
l'
            MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
forall s. MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
copyMutableByteArray MBA s
mba Int
0 MBA s
mba2 Int
0 Int
l'
            BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba2
            (ShortByteString, a) -> ST s (ShortByteString, a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#, a
res)
{-# INLINE createAndTrim #-}

createAndTrim' :: Int -> (forall s. MBA s -> ST s Int) -> ShortByteString
createAndTrim' :: Int -> (forall s. MBA s -> ST s Int) -> ShortByteString
createAndTrim' Int
l forall s. MBA s -> ST s Int
fill =
    (forall s. ST s ShortByteString) -> ShortByteString
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s ShortByteString) -> ShortByteString)
-> (forall s. ST s ShortByteString) -> ShortByteString
forall a b. (a -> b) -> a -> b
$ do
      MBA s
mba <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
l
      Int
l' <- MBA s -> ST s Int
forall s. MBA s -> ST s Int
fill MBA s
mba
      if Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l
          then do
            BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba
            ShortByteString -> ST s ShortByteString
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#)
          else do
            MBA s
mba2 <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
l'
            MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
forall s. MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
copyMutableByteArray MBA s
mba Int
0 MBA s
mba2 Int
0 Int
l'
            BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba2
            ShortByteString -> ST s ShortByteString
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#)
{-# INLINE createAndTrim' #-}

createAndTrim'' :: Int -> (forall s. MBA s -> MBA s -> ST s (Int, Int)) -> (ShortByteString, ShortByteString)
createAndTrim'' :: Int
-> (forall s. MBA s -> MBA s -> ST s (Int, Int))
-> (ShortByteString, ShortByteString)
createAndTrim'' Int
l forall s. MBA s -> MBA s -> ST s (Int, Int)
fill =
    (forall s. ST s (ShortByteString, ShortByteString))
-> (ShortByteString, ShortByteString)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (ShortByteString, ShortByteString))
 -> (ShortByteString, ShortByteString))
-> (forall s. ST s (ShortByteString, ShortByteString))
-> (ShortByteString, ShortByteString)
forall a b. (a -> b) -> a -> b
$ do
      MBA s
mba1 <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
l
      MBA s
mba2 <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
l
      (Int
l1, Int
l2) <- MBA s -> MBA s -> ST s (Int, Int)
forall s. MBA s -> MBA s -> ST s (Int, Int)
fill MBA s
mba1 MBA s
mba2
      ShortByteString
sbs1 <- Int -> MBA s -> ST s ShortByteString
forall s. Int -> MBA s -> ST s ShortByteString
freeze' Int
l1 MBA s
mba1
      ShortByteString
sbs2 <- Int -> MBA s -> ST s ShortByteString
forall s. Int -> MBA s -> ST s ShortByteString
freeze' Int
l2 MBA s
mba2
      (ShortByteString, ShortByteString)
-> ST s (ShortByteString, ShortByteString)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShortByteString
sbs1, ShortByteString
sbs2)
  where
    freeze' :: Int -> MBA s -> ST s ShortByteString
    freeze' :: forall s. Int -> MBA s -> ST s ShortByteString
freeze' Int
l' MBA s
mba =
      if Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l
          then do
            BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba
            ShortByteString -> ST s ShortByteString
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#)
          else do
            MBA s
mba2 <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
l'
            MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
forall s. MBA s -> Int -> MBA s -> Int -> Int -> ST s ()
copyMutableByteArray MBA s
mba Int
0 MBA s
mba2 Int
0 Int
l'
            BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba2
            ShortByteString -> ST s ShortByteString
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#)
{-# INLINE createAndTrim'' #-}

-- Returns the index of the first match or the length of the whole
-- bytestring if nothing matched.
findIndexOrLength :: (Word16 -> Bool) -> ShortByteString -> Int
findIndexOrLength :: (Word16 -> Bool) -> ShortByteString -> Int
findIndexOrLength Word16 -> Bool
k (ShortByteString -> ShortByteString
assertEven -> ShortByteString
sbs) = Int -> Int
go Int
0
  where
    l :: Int
l = ShortByteString -> Int
BS.length ShortByteString
sbs
    ba :: BA
ba = ShortByteString -> BA
asBA ShortByteString
sbs
    w :: Int -> Word16
w = BA -> Int -> Word16
indexWord16Array BA
ba
    go :: Int -> Int
go !Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l     = Int
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
          | Word16 -> Bool
k (Int -> Word16
w Int
n)    = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
          | Bool
otherwise  = Int -> Int
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
{-# INLINE findIndexOrLength #-}


-- | Returns the length of the substring matching, not the index.
-- If no match, returns 0.
findFromEndUntil :: (Word16 -> Bool) -> ShortByteString -> Int
findFromEndUntil :: (Word16 -> Bool) -> ShortByteString -> Int
findFromEndUntil Word16 -> Bool
k ShortByteString
sbs = Int -> Int
go (ShortByteString -> Int
BS.length ShortByteString
sbs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
  where
    ba :: BA
ba = ShortByteString -> BA
asBA ShortByteString
sbs
    w :: Int -> Word16
w = BA -> Int -> Word16
indexWord16Array BA
ba
    go :: Int -> Int
go !Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = Int
0
          | Word16 -> Bool
k (Int -> Word16
w Int
n)   = (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
          | Bool
otherwise = Int -> Int
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
{-# INLINE findFromEndUntil #-}


assertEven :: ShortByteString -> ShortByteString
assertEven :: ShortByteString -> ShortByteString
assertEven sbs :: ShortByteString
sbs@(SBS ByteArray#
barr#)
  | Int -> Bool
forall a. Integral a => a -> Bool
even (Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
barr#)) = ShortByteString
sbs
  | Bool
otherwise = [Char] -> ShortByteString
forall a. HasCallStack => [Char] -> a
error ([Char]
"Uneven number of bytes: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (ShortByteString -> Int
BS.length ShortByteString
sbs) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
". This is not a Word16 bytestream.")


-- Common up near identical calls to `error' to reduce the number
-- constant strings created when compiled:
errorEmptySBS :: HasCallStack => String -> a
errorEmptySBS :: forall a. HasCallStack => [Char] -> a
errorEmptySBS [Char]
fun = [Char] -> [Char] -> a
forall a. HasCallStack => [Char] -> [Char] -> a
moduleError [Char]
fun [Char]
"empty ShortByteString"
{-# NOINLINE errorEmptySBS #-}

moduleError :: HasCallStack => String -> String -> a
moduleError :: forall a. HasCallStack => [Char] -> [Char] -> a
moduleError [Char]
fun [Char]
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char] -> [Char]
moduleErrorMsg [Char]
fun [Char]
msg)
{-# NOINLINE moduleError #-}

compareByteArraysOff :: BA  -- ^ array 1
                     -> Int -- ^ offset for array 1
                     -> BA  -- ^ array 2
                     -> Int -- ^ offset for array 2
                     -> Int -- ^ length to compare
                     -> Int -- ^ like memcmp
#if MIN_VERSION_base(4,11,0)
compareByteArraysOff :: BA -> Int -> BA -> Int -> Int -> Int
compareByteArraysOff (BA# ByteArray#
ba1#) (I# Int#
ba1off#) (BA# ByteArray#
ba2#) (I# Int#
ba2off#) (I# Int#
len#) =
  Int# -> Int
I# (ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#
compareByteArrays#  ByteArray#
ba1# Int#
ba1off# ByteArray#
ba2# Int#
ba2off# Int#
len#)
#else
compareByteArraysOff (BA# ba1#) ba1off (BA# ba2#) ba2off len =
  assert (ba1off + len <= (I# (sizeofByteArray# ba1#)))
  $ assert (ba2off + len <= (I# (sizeofByteArray# ba2#)))
  $ fromIntegral $ accursedUnutterablePerformIO $
    c_memcmp_ByteArray ba1#
                       ba1off
                       ba2#
                       ba2off
                       (fromIntegral len)


foreign import ccall unsafe "static sbs_memcmp_off"
  c_memcmp_ByteArray :: ByteArray# -> Int -> ByteArray# -> Int -> CSize -> IO CInt
#endif