{-# 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 = unsafeCoerce#

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

pinnedByteArrayFromString0 :: String -> MutableByteArray RealWorld
pinnedByteArrayFromString0 xs = pinnedByteArrayFromStringN0 (length xs) xs

pinnedByteArrayFromStringN0 :: Int -> String -> MutableByteArray RealWorld
pinnedByteArrayFromStringN0 n ys = unsafeDupablePerformIO do
  marr <- newPinnedByteArray (n+1)
  let go !ix [] = if ix == n
        then writeByteArray marr ix (0 :: Word8)
        else fail "pinnedByteArrayFromStringN: list length less than specified size"
      go !ix (x : xs) = if ix < n
        then do
          writeByteArray marr ix (B.c2w x)
          go (ix + 1) xs
        else fail "pinnedByteArrayFromStringN: list length greater than specified size"
  go 0 ys
  pure 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 (Eq,Ord)

instance Show ForeignString where
  showsPrec d (ForeignString fp) = showsPrec d $ unsafeDupablePerformIO $ withForeignPtr (castForeignPtr fp) peekCString

instance IsString ForeignString where
  fromString s = unsafeDupablePerformIO $ do
    cstr <- newCString s
    ForeignString <$> newForeignPtr_ (castPtr cstr)

packForeignString :: ByteString -> ForeignString
packForeignString (PS _fp (plusForeignPtr _fp -> fp) n) = unsafeDupablePerformIO do
  MutableByteArray mba <- newPinnedByteArray (n+1)
  let mpa = MutablePrimArray mba :: MutablePrimArray RealWorld Word8 -- See haskell/primitive#253
  withForeignPtr fp $ \p -> copyPtrToMutablePrimArray mpa 0 p n
  writePrimArray mpa 0 (0 :: Word8) -- null terminate
  -- PrimArray ba <- unsafeFreezePrimArray mpa
  pure $ ForeignString $ ForeignPtr (mutableByteArrayContents# mba) (PlainPtr mba)

withForeignString :: ForeignString -> (CString -> IO r) -> IO r
withForeignString (ForeignString fp) = withForeignPtr (castForeignPtr 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 (fromIntegral -> I# i) = i
{-# inline cint #-}

csize :: CSize -> Int#
csize (fromIntegral -> I# i) = i
{-# inline csize #-}

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