{-# LANGUAGE CPP #-}
module Graphics.GL.GetProcAddress (
getProcAddress,
getProcAddressWithSuffixes,
getExtension,
getProcAddressChecked,
getProcAddressWithSuffixesChecked,
getExtensionChecked,
getVersion, version,
getExtensions, extensions
) where
#if !MIN_VERSION_base(4,8,0)
import Data.Functor( (<$>), (<$) )
#endif
import Control.Monad ( forM )
import Control.Monad.IO.Class ( MonadIO(..) )
import Data.ByteString.Unsafe ( unsafePackCString, unsafeUseAsCString )
import Data.Char ( isDigit )
import Data.Set ( Set, fromList )
import Data.Text ( pack, unpack )
import Data.Text.Encoding ( encodeUtf8, decodeUtf8 )
import Foreign.C.String ( CString )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Error ( throwIf )
import Foreign.Ptr ( Ptr, nullPtr, castPtr, FunPtr, nullFunPtr )
import Foreign.Storable ( peek )
import Graphics.GL.Tokens
import Graphics.GL.Types
import System.IO.Unsafe ( unsafePerformIO )
import Text.ParserCombinators.ReadP
getProcAddress :: MonadIO m => String -> m (FunPtr a)
getProcAddress :: forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
cmd = IO (FunPtr a) -> m (FunPtr a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr a) -> m (FunPtr a)) -> IO (FunPtr a) -> m (FunPtr a)
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO (FunPtr a)) -> IO (FunPtr a)
forall a. String -> (CString -> IO a) -> IO a
withUtf8String String
cmd CString -> IO (FunPtr a)
forall a. CString -> IO (FunPtr a)
hs_OpenGLRaw_getProcAddress
foreign import ccall unsafe "hs_OpenGLRaw_getProcAddress"
hs_OpenGLRaw_getProcAddress :: CString -> IO (FunPtr a)
getProcAddressChecked :: MonadIO m => String -> m (FunPtr a)
getProcAddressChecked :: forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddressChecked String
cmd = IO (FunPtr a) -> m (FunPtr a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr a) -> m (FunPtr a)) -> IO (FunPtr a) -> m (FunPtr a)
forall a b. (a -> b) -> a -> b
$ String -> IO (FunPtr a) -> IO (FunPtr a)
forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
check String
cmd (IO (FunPtr a) -> IO (FunPtr a)) -> IO (FunPtr a) -> IO (FunPtr a)
forall a b. (a -> b) -> a -> b
$ String -> IO (FunPtr a)
forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
cmd
getProcAddressWithSuffixes :: MonadIO m => String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixes :: forall (m :: * -> *) a.
MonadIO m =>
String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixes String
_ [] = FunPtr a -> m (FunPtr a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
forall a. FunPtr a
nullFunPtr
getProcAddressWithSuffixes String
cmd (String
x:[String]
xs) = do
p <- String -> m (FunPtr a)
forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress (String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
if p == nullFunPtr
then getProcAddressWithSuffixes cmd xs
else return p
getProcAddressWithSuffixesChecked :: MonadIO m
=> String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixesChecked :: forall (m :: * -> *) a.
MonadIO m =>
String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixesChecked String
cmd [String]
suffixes =
IO (FunPtr a) -> m (FunPtr a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr a) -> m (FunPtr a)) -> IO (FunPtr a) -> m (FunPtr a)
forall a b. (a -> b) -> a -> b
$ String -> IO (FunPtr a) -> IO (FunPtr a)
forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
check String
cmd (IO (FunPtr a) -> IO (FunPtr a)) -> IO (FunPtr a) -> IO (FunPtr a)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO (FunPtr a)
forall (m :: * -> *) a.
MonadIO m =>
String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixes String
cmd [String]
suffixes
getExtension :: MonadIO m => String -> m (FunPtr a)
getExtension :: forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getExtension String
cmd = IO (FunPtr a) -> m (FunPtr a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr a) -> m (FunPtr a)) -> IO (FunPtr a) -> m (FunPtr a)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO (FunPtr a)
forall (m :: * -> *) a.
MonadIO m =>
String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixes String
cmd [String]
vendorSuffixes
getExtensionChecked :: MonadIO m => String -> m (FunPtr a)
getExtensionChecked :: forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getExtensionChecked String
cmd =
IO (FunPtr a) -> m (FunPtr a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr a) -> m (FunPtr a)) -> IO (FunPtr a) -> m (FunPtr a)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO (FunPtr a)
forall (m :: * -> *) a.
MonadIO m =>
String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixesChecked String
cmd [String]
vendorSuffixes
check :: String -> IO (FunPtr a) -> IO (FunPtr a)
check :: forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
check = String -> IO (FunPtr a) -> IO (FunPtr a)
forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
throwIfNullFunPtr (String -> IO (FunPtr a) -> IO (FunPtr a))
-> (String -> String) -> String -> IO (FunPtr a) -> IO (FunPtr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"unknown OpenGL command " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)
throwIfNullFunPtr :: forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
throwIfNullFunPtr = (FunPtr a -> Bool)
-> (FunPtr a -> String) -> IO (FunPtr a) -> IO (FunPtr a)
forall a. (a -> Bool) -> (a -> String) -> IO a -> IO a
throwIf (FunPtr a -> FunPtr a -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr a
forall a. FunPtr a
nullFunPtr) ((FunPtr a -> String) -> IO (FunPtr a) -> IO (FunPtr a))
-> (String -> FunPtr a -> String)
-> String
-> IO (FunPtr a)
-> IO (FunPtr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FunPtr a -> String
forall a b. a -> b -> a
const
vendorSuffixes :: [String]
vendorSuffixes :: [String]
vendorSuffixes = [
String
"",
String
"ARB", String
"KHR", String
"OES",
String
"EXT",
String
"NV", String
"SGIX", String
"AMD", String
"APPLE", String
"ATI", String
"SGIS", String
"ANGLE", String
"QCOM", String
"IMG", String
"SUN",
String
"IBM", String
"ARM", String
"MESA", String
"INTEL", String
"HP", String
"SGI", String
"OML", String
"INGR", String
"3DFX", String
"WIN",
String
"PGI", String
"NVX", String
"GREMEDY", String
"DMP", String
"VIV", String
"SUNX", String
"S3", String
"REND", String
"MESAX", String
"FJ",
String
"ANDROID" ]
getExtensions :: MonadIO m => m (Set String)
getExtensions :: forall (m :: * -> *). MonadIO m => m (Set String)
getExtensions = IO (Set String) -> m (Set String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set String) -> m (Set String))
-> IO (Set String) -> m (Set String)
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
Data.Set.fromList ([String] -> Set String) -> IO [String] -> IO (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
getString <- IO (GLuint -> IO String)
makeGetString
v <- getVersionWith getString
if v >= (3, 0)
then do getInteger <- makeGetInteger
getStringi <- makeGetStringi
numExtensions <- getInteger GL_NUM_EXTENSIONS
forM [ 0 .. fromIntegral numExtensions - 1 ] $
getStringi GL_EXTENSIONS
else words <$> getString GL_EXTENSIONS
getVersion :: MonadIO m => m (Int, Int)
getVersion :: forall (m :: * -> *). MonadIO m => m (Int, Int)
getVersion = IO (Int, Int) -> m (Int, Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, Int) -> m (Int, Int)) -> IO (Int, Int) -> m (Int, Int)
forall a b. (a -> b) -> a -> b
$ IO (GLuint -> IO String)
makeGetString IO (GLuint -> IO String)
-> ((GLuint -> IO String) -> IO (Int, Int)) -> IO (Int, Int)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (GLuint -> IO String) -> IO (Int, Int)
getVersionWith
getVersionWith :: (GLenum -> IO String) -> IO (Int, Int)
getVersionWith :: (GLuint -> IO String) -> IO (Int, Int)
getVersionWith GLuint -> IO String
getString =
ReadP (Int, Int) -> (Int, Int) -> String -> (Int, Int)
forall a. ReadP a -> a -> String -> a
runParser ReadP (Int, Int)
parseVersion (-Int
1, -Int
1) (String -> (Int, Int)) -> IO String -> IO (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GLuint -> IO String
getString GLuint
GL_VERSION
runParser :: ReadP a -> a -> String -> a
runParser :: forall a. ReadP a -> a -> String -> a
runParser ReadP a
parser a
failed String
str =
case ReadP a -> ReadS a
forall a. ReadP a -> ReadS a
readP_to_S ReadP a
parser String
str of
[(a
v, String
"")] -> a
v
[(a, String)]
_ -> a
failed
parseVersion :: ReadP (Int, Int)
parseVersion :: ReadP (Int, Int)
parseVersion = do
_prefix <-
(String
"CL" String -> ReadP String -> ReadP String
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"OpenGL ES-CL ") ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++
(String
"CM" String -> ReadP String -> ReadP String
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"OpenGL ES-CM ") ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++
(String
"ES" String -> ReadP String -> ReadP String
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"OpenGL ES " ) ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++
(String
"GL" String -> ReadP String -> ReadP String
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"" )
major <- read <$> munch1 isDigit
minor <- char '.' >> read <$> munch1 isDigit
_release <- (char '.' >> munch1 (/= ' ')) <++ return ""
_vendorStuff <- (char ' ' >> get `manyTill` eof) <++ ("" <$ eof)
return (major, minor)
makeGetString :: IO (GLenum -> IO String)
makeGetString :: IO (GLuint -> IO String)
makeGetString = do
glGetString_ <- FunPtr (GLuint -> IO (Ptr GLubyte)) -> GLuint -> IO (Ptr GLubyte)
dynGLenumIOPtrGLubyte (FunPtr (GLuint -> IO (Ptr GLubyte)) -> GLuint -> IO (Ptr GLubyte))
-> IO (FunPtr (GLuint -> IO (Ptr GLubyte)))
-> IO (GLuint -> IO (Ptr GLubyte))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (FunPtr (GLuint -> IO (Ptr GLubyte)))
forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
"glGetString"
return $ \GLuint
name -> GLuint -> IO (Ptr GLubyte)
glGetString_ GLuint
name IO (Ptr GLubyte) -> (Ptr GLubyte -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr GLubyte -> IO String
peekGLstring
foreign import CALLCONV "dynamic" dynGLenumIOPtrGLubyte
:: FunPtr (GLenum -> IO (Ptr GLubyte))
-> GLenum -> IO (Ptr GLubyte)
makeGetStringi :: IO (GLenum -> GLuint -> IO String)
makeGetStringi :: IO (GLuint -> GLuint -> IO String)
makeGetStringi = do
glGetStringi_ <- FunPtr (GLuint -> GLuint -> IO (Ptr GLubyte))
-> GLuint -> GLuint -> IO (Ptr GLubyte)
dynGLenumGLuintIOPtrGLubyte (FunPtr (GLuint -> GLuint -> IO (Ptr GLubyte))
-> GLuint -> GLuint -> IO (Ptr GLubyte))
-> IO (FunPtr (GLuint -> GLuint -> IO (Ptr GLubyte)))
-> IO (GLuint -> GLuint -> IO (Ptr GLubyte))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (FunPtr (GLuint -> GLuint -> IO (Ptr GLubyte)))
forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
"glGetStringi"
return $ \GLuint
name GLuint
index -> GLuint -> GLuint -> IO (Ptr GLubyte)
glGetStringi_ GLuint
name GLuint
index IO (Ptr GLubyte) -> (Ptr GLubyte -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr GLubyte -> IO String
peekGLstring
foreign import CALLCONV "dynamic" dynGLenumGLuintIOPtrGLubyte
:: FunPtr (GLenum -> GLuint -> IO (Ptr GLubyte))
-> GLenum -> GLuint -> IO (Ptr GLubyte)
makeGetInteger :: IO (GLenum -> IO GLint)
makeGetInteger :: IO (GLuint -> IO GLint)
makeGetInteger = do
glGetIntegerv_ <- FunPtr (GLuint -> Ptr GLint -> IO ())
-> GLuint -> Ptr GLint -> IO ()
dynGLenumPtrGLintIOVoid (FunPtr (GLuint -> Ptr GLint -> IO ())
-> GLuint -> Ptr GLint -> IO ())
-> IO (FunPtr (GLuint -> Ptr GLint -> IO ()))
-> IO (GLuint -> Ptr GLint -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (FunPtr (GLuint -> Ptr GLint -> IO ()))
forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
"glGetIntegerv"
return $ \GLuint
name -> (Ptr GLint -> IO GLint) -> IO GLint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLint -> IO GLint) -> IO GLint)
-> (Ptr GLint -> IO GLint) -> IO GLint
forall a b. (a -> b) -> a -> b
$ \Ptr GLint
p -> GLuint -> Ptr GLint -> IO ()
glGetIntegerv_ GLuint
name Ptr GLint
p IO () -> IO GLint -> IO GLint
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLint -> IO GLint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLint
p
foreign import CALLCONV "dynamic" dynGLenumPtrGLintIOVoid
:: FunPtr (GLenum -> Ptr GLint -> IO ())
-> GLenum -> Ptr GLint -> IO ()
peekGLstring :: Ptr GLubyte -> IO String
peekGLstring :: Ptr GLubyte -> IO String
peekGLstring = IO String -> (Ptr GLubyte -> IO String) -> Ptr GLubyte -> IO String
forall b a. b -> (Ptr a -> b) -> Ptr a -> b
ptr (String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"") (CString -> IO String
peekUtf8String (CString -> IO String)
-> (Ptr GLubyte -> CString) -> Ptr GLubyte -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr GLubyte -> CString
forall a b. Ptr a -> Ptr b
castPtr)
ptr :: b -> (Ptr a -> b) -> Ptr a -> b
ptr :: forall b a. b -> (Ptr a -> b) -> Ptr a -> b
ptr b
n Ptr a -> b
f Ptr a
p | Ptr a
p Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr = b
n
| Bool
otherwise = Ptr a -> b
f Ptr a
p
withUtf8String :: String -> (CString -> IO a) -> IO a
withUtf8String :: forall a. String -> (CString -> IO a) -> IO a
withUtf8String = ByteString -> (CString -> IO a) -> IO a
forall a. ByteString -> (CString -> IO a) -> IO a
unsafeUseAsCString (ByteString -> (CString -> IO a) -> IO a)
-> (String -> ByteString) -> String -> (CString -> IO a) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\0")
peekUtf8String :: CString -> IO String
peekUtf8String :: CString -> IO String
peekUtf8String CString
p = Text -> String
unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO ByteString
unsafePackCString CString
p
extensions :: Set String
extensions :: Set String
extensions = IO (Set String) -> Set String
forall a. IO a -> a
unsafePerformIO IO (Set String)
forall (m :: * -> *). MonadIO m => m (Set String)
getExtensions
{-# NOINLINE extensions #-}
version :: (Int, Int)
version :: (Int, Int)
version = IO (Int, Int) -> (Int, Int)
forall a. IO a -> a
unsafePerformIO IO (Int, Int)
forall (m :: * -> *). MonadIO m => m (Int, Int)
getVersion
{-# NOINLINE version #-}