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