{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Foreign.FAI.Types
( Pf
, Buffer(..)
, Context(..)
, Accelerate(..)
, FAI(..)
, FAICopy(..)
, FinalizerContextPtr
, Storable(..)
, Ptr
, ForeignPtr
, liftIO
) where
import Control.Monad.IO.Class (MonadIO (..))
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
type family Pf p t :: *
data Buffer p a = Buffer
{ bufPtr :: {-# UNPACK #-} !(ForeignPtr (Pf p a))
, bufSize :: {-# UNPACK #-} !Int
}
deriving (Show, Eq)
newtype Context p = Context
{ unContextPtr :: ForeignPtr (Context p)
}
deriving (Show, Eq)
newtype Accelerate p a = Accelerate
{ doAccelerate :: Context p -> IO (a, Context p)
}
type FinalizerContextPtr p a =
Either (FinalizerEnvPtr (Context p) a) (FinalizerPtr a)
class FAI p where
faiMemAllocate :: Context p
-> Int
-> IO (Ptr a)
faiMemRelease :: Context p
-> Ptr a
-> IO ()
faiMemReleaseP :: Context p
-> IO (FinalizerContextPtr p a)
class (FAI p1, FAI p2) => FAICopy p1 p2 where
faiMemCopy :: (Storable b, (Pf p1 a) ~ b, Storable c, (Pf p2 a) ~ c)
=> Buffer p2 a
-> Buffer p1 a
-> IO ()
instance Functor (Accelerate p) where
fmap f (Accelerate a) = Accelerate $ \c -> do
(r,c') <- a c
return (f r, c')
instance Applicative (Accelerate p) where
pure x = Accelerate $ \c -> return (x, c)
(<*>) (Accelerate ff) (Accelerate fa) = Accelerate $ \c1 -> do
(r1,c2) <- fa c1
(r2,c3) <- ff c2
return (r2 r1, c3)
instance Monad (Accelerate p) where
(>>=) (Accelerate a) mf = Accelerate $ \c1 -> do
(r1, c2) <- a c1
let (Accelerate m) = mf r1
m c2
instance MonadIO (Accelerate p) where
liftIO m = Accelerate $ \c -> (\r -> (r,c)) <$> m