{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
-- 'Delete' and 'Finalizer' instances are necessarily orphan instances due to TH staging restrictions.
{-# OPTIONS_GHC -Wno-orphans #-}

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

    -- * Functions
    moveToByteString,
    withString,

    -- * Low level functions
    new,
    delete,

    -- * Wrapper-based functions
    copyToByteString,
  )
where

import Control.Exception (mask_)
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafePackMallocCStringLen)
import Foreign hiding (new)
import Hercules.CNix.Encapsulation
import Hercules.CNix.Memory (Delete (..), Finalizer (finalizer), withDelete)
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 = IO ByteString -> IO ByteString
forall a. IO a -> IO a
mask_ (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr CChar)
ptr -> (Ptr CSize -> IO ByteString) -> IO ByteString
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' <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
sz
  Ptr CChar
ptr' <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CChar)
ptr
  CStringLen -> IO ByteString
unsafePackMallocCStringLen (Ptr CChar
ptr', CSize -> Int
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);
  }|]

instance Delete CStdString where
  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 = IO (Ptr CStdString) -> (Ptr CStdString -> IO a) -> IO a
forall a b. Delete a => IO (Ptr a) -> (Ptr a -> IO b) -> IO b
withDelete (ByteString -> IO (Ptr CStdString)
new ByteString
bs)

instance Finalizer CStdString where
  finalizer :: FinalizerPtr CStdString
finalizer = FinalizerPtr CStdString
finalize -- must be a CAF

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

newtype StdString = StdString (ForeignPtr CStdString)

instance HasEncapsulation CStdString StdString

copyToByteString :: StdString -> IO ByteString
copyToByteString :: StdString -> IO ByteString
copyToByteString (StdString ForeignPtr CStdString
s) = IO ByteString -> IO ByteString
forall a. IO a -> IO a
mask_ (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr CChar)
ptr -> (Ptr CSize -> IO ByteString) -> IO ByteString
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' <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
sz
  Ptr CChar
ptr' <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CChar)
ptr
  CStringLen -> IO ByteString
unsafePackMallocCStringLen (Ptr CChar
ptr', CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz')