{-# LANGUAGE
  MultiParamTypeClasses,
  UndecidableInstances
  #-}
module LLVM.Internal.MemoryBuffer where

import LLVM.Prelude

import Control.Monad.AnyCont
import Control.Monad.Catch
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Foreign.Ptr

import LLVM.Exception
import LLVM.Internal.Coding
import LLVM.Internal.String
import qualified LLVM.Internal.FFI.LLVMCTypes as FFI
import qualified LLVM.Internal.FFI.MemoryBuffer as FFI

data Specification 
  = Bytes { Specification -> String
name :: String,  Specification -> ByteString
content :: BS.ByteString }
  | File { Specification -> String
pathName :: String }

instance (MonadThrow m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where
  encodeM :: HasCallStack =>
Specification -> m (OwnerTransfered (Ptr MemoryBuffer))
encodeM Specification
spec = (Ptr MemoryBuffer -> OwnerTransfered (Ptr MemoryBuffer))
-> m (Ptr MemoryBuffer) -> m (OwnerTransfered (Ptr MemoryBuffer))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Ptr MemoryBuffer -> OwnerTransfered (Ptr MemoryBuffer)
forall a. a -> OwnerTransfered a
FFI.OwnerTransfered (m (Ptr MemoryBuffer) -> m (OwnerTransfered (Ptr MemoryBuffer)))
-> m (Ptr MemoryBuffer) -> m (OwnerTransfered (Ptr MemoryBuffer))
forall a b. (a -> b) -> a -> b
$ do
    case Specification
spec of
      Bytes String
name ByteString
content -> do
        (CString
s,Int
l) <- (forall r. ((CString, Int) -> IO r) -> IO r) -> m (CString, Int)
forall a. (forall r. (a -> IO r) -> IO r) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadAnyCont b m =>
(forall r. (a -> b r) -> b r) -> m a
anyContToM ((forall r. ((CString, Int) -> IO r) -> IO r) -> m (CString, Int))
-> (forall r. ((CString, Int) -> IO r) -> IO r) -> m (CString, Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> ((CString, Int) -> IO r) -> IO r
forall a. ByteString -> ((CString, Int) -> IO a) -> IO a
BS.unsafeUseAsCStringLen (ByteString -> Word8 -> ByteString
BS.snoc ByteString
content Word8
0)
        CString
name <- String -> m CString
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM String
name
        LLVMBool
nullTerminate <- Bool -> m LLVMBool
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM Bool
True
        IO (Ptr MemoryBuffer) -> m (Ptr MemoryBuffer)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr MemoryBuffer) -> m (Ptr MemoryBuffer))
-> IO (Ptr MemoryBuffer) -> m (Ptr MemoryBuffer)
forall a b. (a -> b) -> a -> b
$ CString -> CSize -> CString -> LLVMBool -> IO (Ptr MemoryBuffer)
FFI.createMemoryBufferWithMemoryRange CString
s (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) CString
name LLVMBool
nullTerminate
      File String
pathName -> do
        CString
pathName <- String -> m CString
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM String
pathName
        Ptr (Ptr MemoryBuffer)
mbPtr <- m (Ptr (Ptr MemoryBuffer))
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m) =>
m (Ptr a)
alloca
        Ptr (OwnerTransfered CString)
msgPtr <- m (Ptr (OwnerTransfered CString))
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m) =>
m (Ptr a)
alloca
        Bool
result <- LLVMBool -> m Bool
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM (LLVMBool -> m Bool) -> m LLVMBool -> m Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO LLVMBool -> m LLVMBool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LLVMBool -> m LLVMBool) -> IO LLVMBool -> m LLVMBool
forall a b. (a -> b) -> a -> b
$ CString
-> Ptr (Ptr MemoryBuffer)
-> Ptr (OwnerTransfered CString)
-> IO LLVMBool
FFI.createMemoryBufferWithContentsOfFile CString
pathName Ptr (Ptr MemoryBuffer)
mbPtr Ptr (OwnerTransfered CString)
msgPtr)
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
result (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          String
msg <- Ptr (OwnerTransfered CString) -> m String
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM Ptr (OwnerTransfered CString)
msgPtr
          EncodeException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> EncodeException
EncodeException String
msg)
        Ptr (Ptr MemoryBuffer) -> m (Ptr MemoryBuffer)
forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a
peek Ptr (Ptr MemoryBuffer)
mbPtr          

instance (MonadThrow m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (Ptr FFI.MemoryBuffer) where
  encodeM :: HasCallStack => Specification -> m (Ptr MemoryBuffer)
encodeM Specification
spec = do
    FFI.OwnerTransfered Ptr MemoryBuffer
mb <- Specification -> m (OwnerTransfered (Ptr MemoryBuffer))
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM Specification
spec
    (forall r. (Ptr MemoryBuffer -> IO r) -> IO r)
-> m (Ptr MemoryBuffer)
forall a. (forall r. (a -> IO r) -> IO r) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadAnyCont b m =>
(forall r. (a -> b r) -> b r) -> m a
anyContToM ((forall r. (Ptr MemoryBuffer -> IO r) -> IO r)
 -> m (Ptr MemoryBuffer))
-> (forall r. (Ptr MemoryBuffer -> IO r) -> IO r)
-> m (Ptr MemoryBuffer)
forall a b. (a -> b) -> a -> b
$ IO (Ptr MemoryBuffer)
-> (Ptr MemoryBuffer -> IO ())
-> (Ptr MemoryBuffer -> IO r)
-> IO r
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (Ptr MemoryBuffer -> IO (Ptr MemoryBuffer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr MemoryBuffer
mb) Ptr MemoryBuffer -> IO ()
FFI.disposeMemoryBuffer

instance MonadIO d => DecodeM d BS.ByteString (Ptr FFI.MemoryBuffer) where
  decodeM :: HasCallStack => Ptr MemoryBuffer -> d ByteString
decodeM Ptr MemoryBuffer
p = do
    CString
s <- IO CString -> d CString
forall a. IO a -> d a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CString -> d CString) -> IO CString -> d CString
forall a b. (a -> b) -> a -> b
$ Ptr MemoryBuffer -> IO CString
FFI.getBufferStart Ptr MemoryBuffer
p
    CSize
l <- IO CSize -> d CSize
forall a. IO a -> d a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CSize -> d CSize) -> IO CSize -> d CSize
forall a b. (a -> b) -> a -> b
$ Ptr MemoryBuffer -> IO CSize
FFI.getBufferSize Ptr MemoryBuffer
p
    IO ByteString -> d ByteString
forall a. IO a -> d a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> d ByteString) -> IO ByteString -> d ByteString
forall a b. (a -> b) -> a -> b
$ (CString, Int) -> IO ByteString
BS.packCStringLen (CString
s, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
l)

instance MonadIO d => DecodeM d String (Ptr FFI.MemoryBuffer) where
  decodeM :: HasCallStack => Ptr MemoryBuffer -> d String
decodeM = UTF8ByteString -> d String
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM (UTF8ByteString -> d String)
-> (ByteString -> UTF8ByteString) -> ByteString -> d String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> UTF8ByteString
UTF8ByteString (ByteString -> d String)
-> (Ptr MemoryBuffer -> d ByteString)
-> Ptr MemoryBuffer
-> d String
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Ptr MemoryBuffer -> d ByteString
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM