{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module Hercules.CNix.Std.String
  ( -- * Context
    CStdString,
    stdStringCtx,

    -- * Functions
    moveToByteString,
    withString,

    -- * Low level functions
    new,
    delete,

    -- * Wrapper-based functions
    copyToByteString,
  )
where

import Control.Exception (bracket, mask_)
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafePackMallocCStringLen)
import Foreign hiding (new)
import Hercules.CNix.Encapsulation
import Hercules.CNix.Std.String.Context
import Hercules.CNix.Std.String.Instances ()
import qualified Language.C.Inline as C
import System.IO.Unsafe (unsafePerformIO)
import Prelude

C.context (stdStringCtx <> C.bsCtx <> C.fptrCtx)

C.include "<string>"
C.include "<cstring>"

moveToByteString :: Ptr CStdString -> IO ByteString
moveToByteString :: Ptr CStdString -> IO ByteString
moveToByteString Ptr CStdString
s = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr CChar)
ptr -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr CSize
sz -> do
  [C.block| void {
    const std::string &s = *$(std::string *s);
    size_t sz = *$(size_t *sz) = s.size();
    char *ptr = *$(char **ptr) = (char*)malloc(sz);
    std::memcpy((void *)ptr, s.c_str(), sz);
  }|]
  CSize
sz' <- forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
sz
  Ptr CChar
ptr' <- forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CChar)
ptr
  CStringLen -> IO ByteString
unsafePackMallocCStringLen (Ptr CChar
ptr', forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz')

new :: ByteString -> IO (Ptr CStdString)
new :: ByteString -> IO (Ptr CStdString)
new ByteString
bs =
  [C.block| std::string* {
    return new std::string($bs-ptr:bs, $bs-len:bs);
  }|]

delete :: Ptr CStdString -> IO ()
delete :: Ptr CStdString -> IO ()
delete Ptr CStdString
bs = [C.block| void { delete $(std::string *bs); }|]

withString :: ByteString -> (Ptr CStdString -> IO a) -> IO a
withString :: forall a. ByteString -> (Ptr CStdString -> IO a) -> IO a
withString ByteString
bs = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (ByteString -> IO (Ptr CStdString)
new ByteString
bs) Ptr CStdString -> IO ()
delete

finalize :: FinalizerPtr CStdString
{-# NOINLINE finalize #-}
finalize :: FinalizerPtr CStdString
finalize =
  forall a. IO a -> a
unsafePerformIO
    [C.exp|
      void (*)(std::string *) {
        [](std::string *v) {
          delete v;
        }
      }
    |]

newtype StdString = StdString (ForeignPtr CStdString)

instance HasEncapsulation CStdString StdString where
  moveToForeignPtrWrapper :: Ptr CStdString -> IO StdString
moveToForeignPtrWrapper Ptr CStdString
x = ForeignPtr CStdString -> StdString
StdString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr CStdString
finalize Ptr CStdString
x

copyToByteString :: StdString -> IO ByteString
copyToByteString :: StdString -> IO ByteString
copyToByteString (StdString ForeignPtr CStdString
s) = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr CChar)
ptr -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr CSize
sz -> do
  [C.block| void {
    const std::string &s = *$fptr-ptr:(std::string *s);
    size_t sz = *$(size_t *sz) = s.size();
    char *ptr = *$(char **ptr) = (char*)malloc(sz);
    std::memcpy((void *)ptr, s.c_str(), sz);
  }|]
  CSize
sz' <- forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
sz
  Ptr CChar
ptr' <- forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CChar)
ptr
  CStringLen -> IO ByteString
unsafePackMallocCStringLen (Ptr CChar
ptr', forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz')