{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} module LLVM.Internal.Coding where import LLVM.Prelude import Language.Haskell.TH import Language.Haskell.TH.Quote import Control.Monad.AnyCont import Control.Monad.IO.Class import Foreign.C import Foreign.Ptr import Foreign.Storable (Storable) import qualified Foreign.Storable import qualified Foreign.Marshal.Alloc import qualified Foreign.Marshal.Array import qualified LLVM.Internal.FFI.LLVMCTypes as FFI class EncodeM e h c where encodeM :: h -> e c class DecodeM d h c where decodeM :: c -> d h genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec] genCodingInstance :: TypeQ -> Name -> [(c, h)] -> Q [Dec] genCodingInstance ht :: TypeQ ht ctn :: Name ctn chs :: [(c, h)] chs = do let n :: b -> Maybe a n = Maybe a -> b -> Maybe a forall a b. a -> b -> a const Maybe a forall a. Maybe a Nothing [d| instance Monad m => EncodeM m $(ht) $(conT ctn) where encodeM h = return $ $( caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ] ) instance Monad m => DecodeM m $(ht) $(conT ctn) where decodeM c = return $ $( caseE [| c |] ([ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs] ++ [ match wildP (normalB [e| error ("Decoding failed: Unknown " <> show c) |]) []])) |] allocaArray :: (Integral i, Storable a, MonadAnyCont IO m) => i -> m (Ptr a) allocaArray :: i -> m (Ptr a) allocaArray p :: i p = (forall r. (Ptr a -> IO r) -> IO r) -> m (Ptr a) forall (b :: * -> *) (m :: * -> *) a. MonadAnyCont b m => (forall r. (a -> b r) -> b r) -> m a anyContToM ((forall r. (Ptr a -> IO r) -> IO r) -> m (Ptr a)) -> (forall r. (Ptr a -> IO r) -> IO r) -> m (Ptr a) forall a b. (a -> b) -> a -> b $ Int -> (Ptr a -> IO r) -> IO r forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b Foreign.Marshal.Array.allocaArray (i -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral i p) alloca :: (Storable a, MonadAnyCont IO m) => m (Ptr a) alloca :: m (Ptr a) alloca = (forall r. (Ptr a -> IO r) -> IO r) -> m (Ptr a) forall (b :: * -> *) (m :: * -> *) a. MonadAnyCont b m => (forall r. (a -> b r) -> b r) -> m a anyContToM forall r. (Ptr a -> IO r) -> IO r forall a b. Storable a => (Ptr a -> IO b) -> IO b Foreign.Marshal.Alloc.alloca peek :: (Storable a, MonadIO m) => Ptr a -> m a peek :: Ptr a -> m a peek p :: Ptr a p = IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO a -> m a) -> IO a -> m a forall a b. (a -> b) -> a -> b $ Ptr a -> IO a forall a. Storable a => Ptr a -> IO a Foreign.Storable.peek Ptr a p peekByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> m a peekByteOff :: Ptr a -> Int -> m a peekByteOff p :: Ptr a p i :: Int i = IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO a -> m a) -> IO a -> m a forall a b. (a -> b) -> a -> b $ Ptr a -> Int -> IO a forall a b. Storable a => Ptr b -> Int -> IO a Foreign.Storable.peekByteOff Ptr a p Int i poke :: (Storable a, MonadIO m) => Ptr a -> a -> m () poke :: Ptr a -> a -> m () poke p :: Ptr a p a :: a a = IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ Ptr a -> a -> IO () forall a. Storable a => Ptr a -> a -> IO () Foreign.Storable.poke Ptr a p a a pokeByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> a -> m () pokeByteOff :: Ptr a -> Int -> a -> m () pokeByteOff p :: Ptr a p i :: Int i a :: a a = IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ Ptr a -> Int -> a -> IO () forall a b. Storable a => Ptr b -> Int -> a -> IO () Foreign.Storable.pokeByteOff Ptr a p Int i a a peekArray :: (Integral i, Storable a, MonadIO m) => i -> Ptr a -> m [a] peekArray :: i -> Ptr a -> m [a] peekArray n :: i n p :: Ptr a p = IO [a] -> m [a] forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO [a] -> m [a]) -> IO [a] -> m [a] forall a b. (a -> b) -> a -> b $ Int -> Ptr a -> IO [a] forall a. Storable a => Int -> Ptr a -> IO [a] Foreign.Marshal.Array.peekArray (i -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral i n) Ptr a p instance (Monad m, EncodeM m h c, Storable c, MonadAnyCont IO m) => EncodeM m [h] (CUInt, Ptr c) where encodeM :: [h] -> m (CUInt, Ptr c) encodeM hs :: [h] hs = do [c] hs <- (h -> m c) -> [h] -> m [c] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM h -> m c forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM [h] hs ((forall r. ((CUInt, Ptr c) -> IO r) -> IO r) -> m (CUInt, Ptr c) forall (b :: * -> *) (m :: * -> *) a. MonadAnyCont b m => (forall r. (a -> b r) -> b r) -> m a anyContToM ((forall r. ((CUInt, Ptr c) -> IO r) -> IO r) -> m (CUInt, Ptr c)) -> (forall r. ((CUInt, Ptr c) -> IO r) -> IO r) -> m (CUInt, Ptr c) forall a b. (a -> b) -> a -> b $ \x :: (CUInt, Ptr c) -> IO r x -> [c] -> (Int -> Ptr c -> IO r) -> IO r forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b Foreign.Marshal.Array.withArrayLen [c] hs ((Int -> Ptr c -> IO r) -> IO r) -> (Int -> Ptr c -> IO r) -> IO r forall a b. (a -> b) -> a -> b $ \n :: Int n hs :: Ptr c hs -> (CUInt, Ptr c) -> IO r x (Int -> CUInt forall a b. (Integral a, Num b) => a -> b fromIntegral Int n, Ptr c hs)) instance (Monad m, DecodeM m h c, Storable c, MonadIO m) => DecodeM m [h] (CUInt, Ptr c) where decodeM :: (CUInt, Ptr c) -> m [h] decodeM (n :: CUInt n, ca :: Ptr c ca) = do [c] cs <- IO [c] -> m [c] forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO [c] -> m [c]) -> IO [c] -> m [c] forall a b. (a -> b) -> a -> b $ Int -> Ptr c -> IO [c] forall a. Storable a => Int -> Ptr a -> IO [a] Foreign.Marshal.Array.peekArray (CUInt -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral CUInt n) Ptr c ca (c -> m h) -> [c] -> m [h] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM c -> m h forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM [c] cs instance Monad m => EncodeM m Bool FFI.LLVMBool where encodeM :: Bool -> m LLVMBool encodeM False = LLVMBool -> m LLVMBool forall (m :: * -> *) a. Monad m => a -> m a return (LLVMBool -> m LLVMBool) -> LLVMBool -> m LLVMBool forall a b. (a -> b) -> a -> b $ CUInt -> LLVMBool FFI.LLVMBool 0 encodeM True = LLVMBool -> m LLVMBool forall (m :: * -> *) a. Monad m => a -> m a return (LLVMBool -> m LLVMBool) -> LLVMBool -> m LLVMBool forall a b. (a -> b) -> a -> b $ CUInt -> LLVMBool FFI.LLVMBool 1 instance Monad m => DecodeM m Bool FFI.LLVMBool where decodeM :: LLVMBool -> m Bool decodeM (FFI.LLVMBool 0) = Bool -> m Bool forall (m :: * -> *) a. Monad m => a -> m a return (Bool -> m Bool) -> Bool -> m Bool forall a b. (a -> b) -> a -> b $ Bool False decodeM (FFI.LLVMBool _) = Bool -> m Bool forall (m :: * -> *) a. Monad m => a -> m a return (Bool -> m Bool) -> Bool -> m Bool forall a b. (a -> b) -> a -> b $ Bool True instance (Monad m, EncodeM m h (Ptr c)) => EncodeM m (Maybe h) (Ptr c) where encodeM :: Maybe h -> m (Ptr c) encodeM = m (Ptr c) -> (h -> m (Ptr c)) -> Maybe h -> m (Ptr c) forall b a. b -> (a -> b) -> Maybe a -> b maybe (Ptr c -> m (Ptr c) forall (m :: * -> *) a. Monad m => a -> m a return Ptr c forall a. Ptr a nullPtr) h -> m (Ptr c) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM instance (Monad m, DecodeM m h (Ptr c)) => DecodeM m (Maybe h) (Ptr c) where decodeM :: Ptr c -> m (Maybe h) decodeM p :: Ptr c p | Ptr c p Ptr c -> Ptr c -> Bool forall a. Eq a => a -> a -> Bool == Ptr c forall a. Ptr a nullPtr = Maybe h -> m (Maybe h) forall (m :: * -> *) a. Monad m => a -> m a return Maybe h forall a. Maybe a Nothing | Bool otherwise = (h -> Maybe h) -> m h -> m (Maybe h) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM h -> Maybe h forall a. a -> Maybe a Just (m h -> m (Maybe h)) -> m h -> m (Maybe h) forall a b. (a -> b) -> a -> b $ Ptr c -> m h forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM Ptr c p instance Monad m => EncodeM m (Maybe Bool) (FFI.NothingAsMinusOne Bool) where encodeM :: Maybe Bool -> m (NothingAsMinusOne Bool) encodeM = NothingAsMinusOne Bool -> m (NothingAsMinusOne Bool) forall (m :: * -> *) a. Monad m => a -> m a return (NothingAsMinusOne Bool -> m (NothingAsMinusOne Bool)) -> (Maybe Bool -> NothingAsMinusOne Bool) -> Maybe Bool -> m (NothingAsMinusOne Bool) forall b c a. (b -> c) -> (a -> b) -> a -> c . CInt -> NothingAsMinusOne Bool forall h. CInt -> NothingAsMinusOne h FFI.NothingAsMinusOne (CInt -> NothingAsMinusOne Bool) -> (Maybe Bool -> CInt) -> Maybe Bool -> NothingAsMinusOne Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . CInt -> (Bool -> CInt) -> Maybe Bool -> CInt forall b a. b -> (a -> b) -> Maybe a -> b maybe (-1) (Int -> CInt forall a b. (Integral a, Num b) => a -> b fromIntegral (Int -> CInt) -> (Bool -> Int) -> Bool -> CInt forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> Int forall a. Enum a => a -> Int fromEnum) instance Monad m => EncodeM m (Maybe Word) (FFI.NothingAsMinusOne Word) where encodeM :: Maybe Word -> m (NothingAsMinusOne Word) encodeM = NothingAsMinusOne Word -> m (NothingAsMinusOne Word) forall (m :: * -> *) a. Monad m => a -> m a return (NothingAsMinusOne Word -> m (NothingAsMinusOne Word)) -> (Maybe Word -> NothingAsMinusOne Word) -> Maybe Word -> m (NothingAsMinusOne Word) forall b c a. (b -> c) -> (a -> b) -> a -> c . CInt -> NothingAsMinusOne Word forall h. CInt -> NothingAsMinusOne h FFI.NothingAsMinusOne (CInt -> NothingAsMinusOne Word) -> (Maybe Word -> CInt) -> Maybe Word -> NothingAsMinusOne Word forall b c a. (b -> c) -> (a -> b) -> a -> c . CInt -> (Word -> CInt) -> Maybe Word -> CInt forall b a. b -> (a -> b) -> Maybe a -> b maybe (-1) Word -> CInt forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => EncodeM m (Maybe Word32) (CUInt, FFI.LLVMBool) where encodeM :: Maybe Word32 -> m (CUInt, LLVMBool) encodeM (Just a :: Word32 a) = (CUInt -> LLVMBool -> (CUInt, LLVMBool)) -> m CUInt -> m LLVMBool -> m (CUInt, LLVMBool) forall (m :: * -> *) a1 a2 r. Monad m => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r liftM2 (,) (Word32 -> m CUInt forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Word32 a) (Bool -> m LLVMBool forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Bool True) encodeM Nothing = (0,) (LLVMBool -> (CUInt, LLVMBool)) -> m LLVMBool -> m (CUInt, LLVMBool) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Bool -> m LLVMBool forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Bool False instance Monad m => EncodeM m (Maybe Word32) (Word32, FFI.LLVMBool) where encodeM :: Maybe Word32 -> m (Word32, LLVMBool) encodeM (Just a :: Word32 a) = (Word32 a,) (LLVMBool -> (Word32, LLVMBool)) -> m LLVMBool -> m (Word32, LLVMBool) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Bool -> m LLVMBool forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Bool True encodeM Nothing = (0,) (LLVMBool -> (Word32, LLVMBool)) -> m LLVMBool -> m (Word32, LLVMBool) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Bool -> m LLVMBool forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Bool False instance Monad m => EncodeM m Word CUInt where encodeM :: Word -> m CUInt encodeM = CUInt -> m CUInt forall (m :: * -> *) a. Monad m => a -> m a return (CUInt -> m CUInt) -> (Word -> CUInt) -> Word -> m CUInt forall b c a. (b -> c) -> (a -> b) -> a -> c . Word -> CUInt forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => EncodeM m Word32 CUInt where encodeM :: Word32 -> m CUInt encodeM = CUInt -> m CUInt forall (m :: * -> *) a. Monad m => a -> m a return (CUInt -> m CUInt) -> (Word32 -> CUInt) -> Word32 -> m CUInt forall b c a. (b -> c) -> (a -> b) -> a -> c . Word32 -> CUInt forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => EncodeM m Word64 CULong where encodeM :: Word64 -> m CULong encodeM = CULong -> m CULong forall (m :: * -> *) a. Monad m => a -> m a return (CULong -> m CULong) -> (Word64 -> CULong) -> Word64 -> m CULong forall b c a. (b -> c) -> (a -> b) -> a -> c . Word64 -> CULong forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => DecodeM m Word CUInt where decodeM :: CUInt -> m Word decodeM = Word -> m Word forall (m :: * -> *) a. Monad m => a -> m a return (Word -> m Word) -> (CUInt -> Word) -> CUInt -> m Word forall b c a. (b -> c) -> (a -> b) -> a -> c . CUInt -> Word forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => DecodeM m Word32 CUInt where decodeM :: CUInt -> m Word32 decodeM = Word32 -> m Word32 forall (m :: * -> *) a. Monad m => a -> m a return (Word32 -> m Word32) -> (CUInt -> Word32) -> CUInt -> m Word32 forall b c a. (b -> c) -> (a -> b) -> a -> c . CUInt -> Word32 forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => DecodeM m Word64 CULong where decodeM :: CULong -> m Word64 decodeM = Word64 -> m Word64 forall (m :: * -> *) a. Monad m => a -> m a return (Word64 -> m Word64) -> (CULong -> Word64) -> CULong -> m Word64 forall b c a. (b -> c) -> (a -> b) -> a -> c . CULong -> Word64 forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => EncodeM m Int32 CInt where encodeM :: Int32 -> m CInt encodeM = CInt -> m CInt forall (m :: * -> *) a. Monad m => a -> m a return (CInt -> m CInt) -> (Int32 -> CInt) -> Int32 -> m CInt forall b c a. (b -> c) -> (a -> b) -> a -> c . Int32 -> CInt forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => DecodeM m Int32 CInt where decodeM :: CInt -> m Int32 decodeM = Int32 -> m Int32 forall (m :: * -> *) a. Monad m => a -> m a return (Int32 -> m Int32) -> (CInt -> Int32) -> CInt -> m Int32 forall b c a. (b -> c) -> (a -> b) -> a -> c . CInt -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => DecodeM m Int CInt where decodeM :: CInt -> m Int decodeM = Int -> m Int forall (m :: * -> *) a. Monad m => a -> m a return (Int -> m Int) -> (CInt -> Int) -> CInt -> m Int forall b c a. (b -> c) -> (a -> b) -> a -> c . CInt -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral instance Monad m => EncodeM m Word64 Word64 where encodeM :: Word64 -> m Word64 encodeM = Word64 -> m Word64 forall (m :: * -> *) a. Monad m => a -> m a return instance Monad m => DecodeM m Word64 Word64 where decodeM :: Word64 -> m Word64 decodeM = Word64 -> m Word64 forall (m :: * -> *) a. Monad m => a -> m a return decodeOptional :: (DecodeM m b a, Storable a, MonadAnyCont IO m, MonadIO m) => (Ptr a -> IO FFI.LLVMBool) -> m (Maybe b) decodeOptional :: (Ptr a -> IO LLVMBool) -> m (Maybe b) decodeOptional f :: Ptr a -> IO LLVMBool f = do Ptr a ptr <- m (Ptr a) forall a (m :: * -> *). (Storable a, MonadAnyCont IO m) => m (Ptr a) alloca Bool isJust <- 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 (Ptr a -> IO LLVMBool f Ptr a ptr) if Bool isJust then b -> Maybe b forall a. a -> Maybe a Just (b -> Maybe b) -> m b -> m (Maybe b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (a -> m b forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (a -> m b) -> m a -> m b forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr a -> m a forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a peek Ptr a ptr) else Maybe b -> m (Maybe b) forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe b forall a. Maybe a Nothing decodeArray :: (DecodeM m b' b, MonadIO m) => (a -> IO CUInt) -> (a -> CUInt -> IO b) -> a -> m [b'] decodeArray :: (a -> IO CUInt) -> (a -> CUInt -> IO b) -> a -> m [b'] decodeArray numElems :: a -> IO CUInt numElems getElem :: a -> CUInt -> IO b getElem a :: a a = do CUInt n <- IO CUInt -> m CUInt forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (a -> IO CUInt numElems a a) if CUInt n CUInt -> CUInt -> Bool forall a. Eq a => a -> a -> Bool == 0 then [b'] -> m [b'] forall (f :: * -> *) a. Applicative f => a -> f a pure [] else (CUInt -> m b') -> [CUInt] -> m [b'] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (b -> m b' forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (b -> m b') -> (CUInt -> m b) -> CUInt -> m b' forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< IO b -> m b forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO b -> m b) -> (CUInt -> IO b) -> CUInt -> m b forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> CUInt -> IO b getElem a a) [0 .. CUInt n CUInt -> CUInt -> CUInt forall a. Num a => a -> a -> a - 1]