{-# 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 :: Specification -> m (OwnerTransfered (Ptr MemoryBuffer))
encodeM spec :: 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 name :: String
name content :: ByteString
content -> do
        (s :: Ptr CChar
s,l :: Int
l) <- (forall r. ((Ptr CChar, Int) -> IO r) -> IO r)
-> m (Ptr CChar, Int)
forall (b :: * -> *) (m :: * -> *) a.
MonadAnyCont b m =>
(forall r. (a -> b r) -> b r) -> m a
anyContToM ((forall r. ((Ptr CChar, Int) -> IO r) -> IO r)
 -> m (Ptr CChar, Int))
-> (forall r. ((Ptr CChar, Int) -> IO r) -> IO r)
-> m (Ptr CChar, Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> ((Ptr CChar, Int) -> IO r) -> IO r
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BS.unsafeUseAsCStringLen (ByteString -> Word8 -> ByteString
BS.snoc ByteString
content 0)
        Ptr CChar
name <- String -> m (Ptr CChar)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM String
name
        LLVMBool
nullTerminate <- Bool -> m LLVMBool
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Bool
True
        IO (Ptr MemoryBuffer) -> m (Ptr MemoryBuffer)
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
$ Ptr CChar
-> CSize -> Ptr CChar -> LLVMBool -> IO (Ptr MemoryBuffer)
FFI.createMemoryBufferWithMemoryRange Ptr CChar
s (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)) Ptr CChar
name LLVMBool
nullTerminate
      File pathName :: String
pathName -> do
        Ptr CChar
pathName <- String -> m (Ptr CChar)
forall (e :: * -> *) h c. EncodeM e h c => 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 (Ptr CChar))
msgPtr <- m (Ptr (OwnerTransfered (Ptr CChar)))
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 => 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LLVMBool -> m LLVMBool) -> IO LLVMBool -> m LLVMBool
forall a b. (a -> b) -> a -> b
$ Ptr CChar
-> Ptr (Ptr MemoryBuffer)
-> Ptr (OwnerTransfered (Ptr CChar))
-> IO LLVMBool
FFI.createMemoryBufferWithContentsOfFile Ptr CChar
pathName Ptr (Ptr MemoryBuffer)
mbPtr Ptr (OwnerTransfered (Ptr CChar))
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 (Ptr CChar)) -> m String
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM Ptr (OwnerTransfered (Ptr CChar))
msgPtr
          EncodeException -> m ()
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 :: Specification -> m (Ptr MemoryBuffer)
encodeM spec :: Specification
spec = do
    FFI.OwnerTransfered mb :: Ptr MemoryBuffer
mb <- Specification -> m (OwnerTransfered (Ptr MemoryBuffer))
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Specification
spec
    (forall r. (Ptr MemoryBuffer -> IO r) -> IO r)
-> m (Ptr MemoryBuffer)
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 (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 :: Ptr MemoryBuffer -> d ByteString
decodeM p :: Ptr MemoryBuffer
p = do
    Ptr CChar
s <- IO (Ptr CChar) -> d (Ptr CChar)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr CChar) -> d (Ptr CChar))
-> IO (Ptr CChar) -> d (Ptr CChar)
forall a b. (a -> b) -> a -> b
$ Ptr MemoryBuffer -> IO (Ptr CChar)
FFI.getBufferStart Ptr MemoryBuffer
p
    CSize
l <- IO CSize -> d CSize
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> d ByteString) -> IO ByteString -> d ByteString
forall a b. (a -> b) -> a -> b
$ (Ptr CChar, Int) -> IO ByteString
BS.packCStringLen (Ptr CChar
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 :: Ptr MemoryBuffer -> d String
decodeM = UTF8ByteString -> d String
forall (d :: * -> *) h c. DecodeM d h c => 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 => c -> d h
decodeM