{-# language MagicHash #-}
{-# language UnboxedTuples #-}
{-# language BlockArguments #-}
{-# language BangPatterns #-}
{-# language ViewPatterns #-}
{-# language UnliftedFFITypes #-}
{-# language UnliftedNewtypes #-}

-- | the proverbial junk drawer
module Text.Parsnip.Internal.Private
( io
, mutableByteArrayContents#
, pinnedByteArrayFromString0
, pinnedByteArrayFromStringN0
, c_memchr
, c_strlen
, c_strncmp
, pure_strlen
, cint
, csize
, mkBS
, ForeignString(..)
, packForeignString
, withForeignString
) where

import Data.Primitive.ByteArray
import Data.Primitive.PrimArray
import Data.Primitive.Ptr
import Data.ByteString.Internal (ByteString(..))
import qualified Data.ByteString.Internal as B
import Data.String
import Data.Word
import Foreign.ForeignPtr
import Foreign.C.String
import Foreign.C.Types
import GHC.ForeignPtr
import GHC.Prim
import GHC.Ptr
import GHC.Types
import System.IO.Unsafe
import Unsafe.Coerce

io :: IO a -> State# s -> (# State# s, a #)
io :: forall a s. IO a -> State# s -> (# State# s, a #)
io = IO a -> State# s -> (# State# s, a #)
unsafeCoerce#

-- | Missing primitive
mutableByteArrayContents# :: MutableByteArray# s -> Addr#
mutableByteArrayContents# :: forall s. MutableByteArray# s -> Addr#
mutableByteArrayContents# MutableByteArray# s
arr = ByteArray# -> Addr#
byteArrayContents# (MutableByteArray# s -> ByteArray#
unsafeCoerce# MutableByteArray# s
arr)

pinnedByteArrayFromString0 :: String -> MutableByteArray RealWorld
pinnedByteArrayFromString0 :: String -> MutableByteArray RealWorld
pinnedByteArrayFromString0 String
xs = Int -> String -> MutableByteArray RealWorld
pinnedByteArrayFromStringN0 (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) String
xs

pinnedByteArrayFromStringN0 :: Int -> String -> MutableByteArray RealWorld
pinnedByteArrayFromStringN0 :: Int -> String -> MutableByteArray RealWorld
pinnedByteArrayFromStringN0 Int
n String
ys = IO (MutableByteArray RealWorld) -> MutableByteArray RealWorld
forall a. IO a -> a
unsafeDupablePerformIO do
  MutableByteArray RealWorld
marr <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  let go :: Int -> String -> IO ()
go !Int
ix [] = if Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
        then MutableByteArray (PrimState IO) -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
marr Int
ix (Word8
0 :: Word8)
        else String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pinnedByteArrayFromStringN: list length less than specified size"
      go !Int
ix (Char
x : String
xs) = if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
        then do
          MutableByteArray (PrimState IO) -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
marr Int
ix (Char -> Word8
B.c2w Char
x)
          Int -> String -> IO ()
go (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
xs
        else String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pinnedByteArrayFromStringN: list length greater than specified size"
  Int -> String -> IO ()
go Int
0 String
ys
  MutableByteArray RealWorld -> IO (MutableByteArray RealWorld)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableByteArray RealWorld
marr

-- | An _immutable_ foreign cstring. This is mostly useful for things like calling strstr through ffi
-- where the needle needs to be null terminated.
newtype ForeignString = ForeignString (ForeignPtr Word8)
  deriving (ForeignString -> ForeignString -> Bool
(ForeignString -> ForeignString -> Bool)
-> (ForeignString -> ForeignString -> Bool) -> Eq ForeignString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForeignString -> ForeignString -> Bool
$c/= :: ForeignString -> ForeignString -> Bool
== :: ForeignString -> ForeignString -> Bool
$c== :: ForeignString -> ForeignString -> Bool
Eq,Eq ForeignString
Eq ForeignString
-> (ForeignString -> ForeignString -> Ordering)
-> (ForeignString -> ForeignString -> Bool)
-> (ForeignString -> ForeignString -> Bool)
-> (ForeignString -> ForeignString -> Bool)
-> (ForeignString -> ForeignString -> Bool)
-> (ForeignString -> ForeignString -> ForeignString)
-> (ForeignString -> ForeignString -> ForeignString)
-> Ord ForeignString
ForeignString -> ForeignString -> Bool
ForeignString -> ForeignString -> Ordering
ForeignString -> ForeignString -> ForeignString
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ForeignString -> ForeignString -> ForeignString
$cmin :: ForeignString -> ForeignString -> ForeignString
max :: ForeignString -> ForeignString -> ForeignString
$cmax :: ForeignString -> ForeignString -> ForeignString
>= :: ForeignString -> ForeignString -> Bool
$c>= :: ForeignString -> ForeignString -> Bool
> :: ForeignString -> ForeignString -> Bool
$c> :: ForeignString -> ForeignString -> Bool
<= :: ForeignString -> ForeignString -> Bool
$c<= :: ForeignString -> ForeignString -> Bool
< :: ForeignString -> ForeignString -> Bool
$c< :: ForeignString -> ForeignString -> Bool
compare :: ForeignString -> ForeignString -> Ordering
$ccompare :: ForeignString -> ForeignString -> Ordering
Ord)

instance Show ForeignString where
  showsPrec :: Int -> ForeignString -> ShowS
showsPrec Int
d (ForeignString ForeignPtr Word8
fp) = Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ IO String -> String
forall a. IO a -> a
unsafeDupablePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ ForeignPtr CChar -> (Ptr CChar -> IO String) -> IO String
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (ForeignPtr Word8 -> ForeignPtr CChar
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Word8
fp) Ptr CChar -> IO String
peekCString

instance IsString ForeignString where
  fromString :: String -> ForeignString
fromString String
s = IO ForeignString -> ForeignString
forall a. IO a -> a
unsafeDupablePerformIO (IO ForeignString -> ForeignString)
-> IO ForeignString -> ForeignString
forall a b. (a -> b) -> a -> b
$ do
    Ptr CChar
cstr <- String -> IO (Ptr CChar)
newCString String
s
    ForeignPtr Word8 -> ForeignString
ForeignString (ForeignPtr Word8 -> ForeignString)
-> IO (ForeignPtr Word8) -> IO ForeignString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> IO (ForeignPtr Word8)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cstr)

packForeignString :: ByteString -> ForeignString
packForeignString :: ByteString -> ForeignString
packForeignString (PS ForeignPtr Word8
_fp (ForeignPtr Word8 -> Int -> ForeignPtr Word8
forall a b. ForeignPtr a -> Int -> ForeignPtr b
plusForeignPtr ForeignPtr Word8
_fp -> ForeignPtr Word8
fp) Int
n) = IO ForeignString -> ForeignString
forall a. IO a -> a
unsafeDupablePerformIO do
  MutableByteArray MutableByteArray# RealWorld
mba <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  let mpa :: MutablePrimArray RealWorld Word8
mpa = MutableByteArray# RealWorld -> MutablePrimArray RealWorld Word8
forall s a. MutableByteArray# s -> MutablePrimArray s a
MutablePrimArray MutableByteArray# RealWorld
mba :: MutablePrimArray RealWorld Word8 -- See haskell/primitive#253
  ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> MutablePrimArray (PrimState IO) Word8
-> Int -> Ptr Word8 -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> Int -> Ptr a -> Int -> m ()
copyPtrToMutablePrimArray MutablePrimArray RealWorld Word8
MutablePrimArray (PrimState IO) Word8
mpa Int
0 Ptr Word8
p Int
n
  MutablePrimArray (PrimState IO) Word8 -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Word8
MutablePrimArray (PrimState IO) Word8
mpa Int
0 (Word8
0 :: Word8) -- null terminate
  -- PrimArray ba <- unsafeFreezePrimArray mpa
  ForeignString -> IO ForeignString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignString -> IO ForeignString)
-> ForeignString -> IO ForeignString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> ForeignString
ForeignString (ForeignPtr Word8 -> ForeignString)
-> ForeignPtr Word8 -> ForeignString
forall a b. (a -> b) -> a -> b
$ Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr (MutableByteArray# RealWorld -> Addr#
forall s. MutableByteArray# s -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
mba) (MutableByteArray# RealWorld -> ForeignPtrContents
PlainPtr MutableByteArray# RealWorld
mba)

withForeignString :: ForeignString -> (CString -> IO r) -> IO r
withForeignString :: forall r. ForeignString -> (Ptr CChar -> IO r) -> IO r
withForeignString (ForeignString ForeignPtr Word8
fp) = ForeignPtr CChar -> (Ptr CChar -> IO r) -> IO r
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (ForeignPtr Word8 -> ForeignPtr CChar
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Word8
fp)

---------------------------------------------------------------------------------------
-- * C
---------------------------------------------------------------------------------------

foreign import ccall unsafe "string.h memchr" c_memchr :: Addr# -> CInt -> CSize -> IO (Ptr ())
foreign import ccall unsafe "string.h strncmp" c_strncmp :: Addr# -> Addr# -> CSize -> IO CInt
foreign import ccall unsafe "string.h strlen" c_strlen :: Addr# -> IO CSize
foreign import ccall unsafe "string.h strlen" pure_strlen :: Addr# -> CSize

cint :: CInt -> Int#
cint :: CInt -> Int#
cint (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> I# Int#
i) = Int#
i
{-# inline cint #-}

csize :: CSize -> Int#
csize :: CSize -> Int#
csize (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> I# Int#
i) = Int#
i
{-# inline csize #-}

mkBS :: Addr# -> ForeignPtrContents -> Int# -> ByteString
mkBS :: Addr# -> ForeignPtrContents -> Int# -> ByteString
mkBS Addr#
b ForeignPtrContents
g Int#
l = ForeignPtr Word8 -> Int -> Int -> ByteString
PS (Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
b ForeignPtrContents
g) Int
0 (Int# -> Int
I# Int#
l)
{-# inline mkBS #-}