{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.IOState
-- Copyright   :  (c) Sven Panne 2002-2019
-- License     :  BSD3
-- 
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This is a purely internal module for an IO monad with a pointer as an
-- additional state, basically a /StateT (Ptr s) IO a/.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.IOState (
   IOState(..), getIOState, peekIOState, evalIOState, nTimes
) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ( Applicative(..) )
#endif
import Control.Monad ( ap, liftM, replicateM )
import Foreign.Ptr ( Ptr, plusPtr )
import Foreign.Storable ( Storable(sizeOf,peek) )

--------------------------------------------------------------------------------

newtype IOState s a = IOState { IOState s a -> Ptr s -> IO (a, Ptr s)
runIOState :: Ptr s -> IO (a, Ptr s) }

instance Applicative (IOState s) where
   pure :: a -> IOState s a
pure  = a -> IOState s a
forall (m :: * -> *) a. Monad m => a -> m a
return
   <*> :: IOState s (a -> b) -> IOState s a -> IOState s b
(<*>) = IOState s (a -> b) -> IOState s a -> IOState s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor (IOState s) where
   fmap :: (a -> b) -> IOState s a -> IOState s b
fmap = (a -> b) -> IOState s a -> IOState s b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Monad (IOState s) where
   return :: a -> IOState s a
return a
a = (Ptr s -> IO (a, Ptr s)) -> IOState s a
forall s a. (Ptr s -> IO (a, Ptr s)) -> IOState s a
IOState ((Ptr s -> IO (a, Ptr s)) -> IOState s a)
-> (Ptr s -> IO (a, Ptr s)) -> IOState s a
forall a b. (a -> b) -> a -> b
$ \Ptr s
s -> (a, Ptr s) -> IO (a, Ptr s)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Ptr s
s)
   IOState s a
m >>= :: IOState s a -> (a -> IOState s b) -> IOState s b
>>= a -> IOState s b
k  = (Ptr s -> IO (b, Ptr s)) -> IOState s b
forall s a. (Ptr s -> IO (a, Ptr s)) -> IOState s a
IOState ((Ptr s -> IO (b, Ptr s)) -> IOState s b)
-> (Ptr s -> IO (b, Ptr s)) -> IOState s b
forall a b. (a -> b) -> a -> b
$ \Ptr s
s -> do (a
a, Ptr s
s') <- IOState s a -> Ptr s -> IO (a, Ptr s)
forall s a. IOState s a -> Ptr s -> IO (a, Ptr s)
runIOState IOState s a
m Ptr s
s ; IOState s b -> Ptr s -> IO (b, Ptr s)
forall s a. IOState s a -> Ptr s -> IO (a, Ptr s)
runIOState (a -> IOState s b
k a
a) Ptr s
s'
#if MIN_VERSION_base(4,13,0)
instance MonadFail (IOState s) where
#endif
   fail :: String -> IOState s a
fail String
str = (Ptr s -> IO (a, Ptr s)) -> IOState s a
forall s a. (Ptr s -> IO (a, Ptr s)) -> IOState s a
IOState ((Ptr s -> IO (a, Ptr s)) -> IOState s a)
-> (Ptr s -> IO (a, Ptr s)) -> IOState s a
forall a b. (a -> b) -> a -> b
$ \Ptr s
_ -> String -> IO (a, Ptr s)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
str

getIOState :: IOState s (Ptr s)
getIOState :: IOState s (Ptr s)
getIOState = (Ptr s -> IO (Ptr s, Ptr s)) -> IOState s (Ptr s)
forall s a. (Ptr s -> IO (a, Ptr s)) -> IOState s a
IOState ((Ptr s -> IO (Ptr s, Ptr s)) -> IOState s (Ptr s))
-> (Ptr s -> IO (Ptr s, Ptr s)) -> IOState s (Ptr s)
forall a b. (a -> b) -> a -> b
$ \Ptr s
s -> (Ptr s, Ptr s) -> IO (Ptr s, Ptr s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr s
s, Ptr s
s)

putIOState :: Ptr s -> IOState s ()
putIOState :: Ptr s -> IOState s ()
putIOState Ptr s
s = (Ptr s -> IO ((), Ptr s)) -> IOState s ()
forall s a. (Ptr s -> IO (a, Ptr s)) -> IOState s a
IOState ((Ptr s -> IO ((), Ptr s)) -> IOState s ())
-> (Ptr s -> IO ((), Ptr s)) -> IOState s ()
forall a b. (a -> b) -> a -> b
$ \Ptr s
_ -> ((), Ptr s) -> IO ((), Ptr s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Ptr s
s)

peekIOState :: Storable a => IOState a a
peekIOState :: IOState a a
peekIOState = do
   Ptr a
ptr <- IOState a (Ptr a)
forall s. IOState s (Ptr s)
getIOState
   a
x <- IO a -> IOState a a
forall a s. IO a -> IOState s a
liftIOState (IO a -> IOState a a) -> IO a -> IOState a a
forall a b. (a -> b) -> a -> b
$ Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
ptr
   Ptr a -> IOState a ()
forall s. Ptr s -> IOState s ()
putIOState (Ptr a
ptr Ptr a -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` a -> Int
forall a. Storable a => a -> Int
sizeOf a
x)
   a -> IOState a a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

liftIOState :: IO a -> IOState s a
liftIOState :: IO a -> IOState s a
liftIOState IO a
m = (Ptr s -> IO (a, Ptr s)) -> IOState s a
forall s a. (Ptr s -> IO (a, Ptr s)) -> IOState s a
IOState ((Ptr s -> IO (a, Ptr s)) -> IOState s a)
-> (Ptr s -> IO (a, Ptr s)) -> IOState s a
forall a b. (a -> b) -> a -> b
$ \Ptr s
s -> do a
a <- IO a
m ; (a, Ptr s) -> IO (a, Ptr s)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Ptr s
s)

evalIOState :: IOState s a -> Ptr s -> IO a
evalIOState :: IOState s a -> Ptr s -> IO a
evalIOState IOState s a
m Ptr s
s = do (a
a, Ptr s
_) <- IOState s a -> Ptr s -> IO (a, Ptr s)
forall s a. IOState s a -> Ptr s -> IO (a, Ptr s)
runIOState IOState s a
m Ptr s
s ; a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

nTimes :: Integral a => a -> IOState b c -> IOState b [c]
nTimes :: a -> IOState b c -> IOState b [c]
nTimes a
n = Int -> IOState b c -> IOState b [c]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n)