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