{-# 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> (CString -> IO a) -> IO a
withUtf8String String
cmd 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
check String
cmd forall a b. (a -> b) -> a -> b
$ 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
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. FunPtr a
nullFunPtr
getProcAddressWithSuffixes String
cmd (String
x:[String]
xs) = do
FunPtr a
p <- forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress (String
cmd forall a. [a] -> [a] -> [a]
++ String
x)
if FunPtr a
p forall a. Eq a => a -> a -> Bool
== forall a. FunPtr a
nullFunPtr
then forall (m :: * -> *) a.
MonadIO m =>
String -> [String] -> m (FunPtr a)
getProcAddressWithSuffixes String
cmd [String]
xs
else forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
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 =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
check String
cmd forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 = forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
throwIfNullFunPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"unknown OpenGL command " forall a. [a] -> [a] -> [a]
++)
throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)
throwIfNullFunPtr :: forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
throwIfNullFunPtr = forall a. (a -> Bool) -> (a -> String) -> IO a -> IO a
throwIf (forall a. Eq a => a -> a -> Bool
== forall a. FunPtr a
nullFunPtr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Data.Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
GLuint -> IO String
getString <- IO (GLuint -> IO String)
makeGetString
(Int, Int)
v <- (GLuint -> IO String) -> IO (Int, Int)
getVersionWith GLuint -> IO String
getString
if (Int, Int)
v forall a. Ord a => a -> a -> Bool
>= (Int
3, Int
0)
then do GLuint -> IO GLint
getInteger <- IO (GLuint -> IO GLint)
makeGetInteger
GLuint -> GLuint -> IO String
getStringi <- IO (GLuint -> GLuint -> IO String)
makeGetStringi
GLint
numExtensions <- GLuint -> IO GLint
getInteger GLuint
GL_NUM_EXTENSIONS
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ GLuint
0 .. forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
numExtensions forall a. Num a => a -> a -> a
- GLuint
1 ] forall a b. (a -> b) -> a -> b
$
GLuint -> GLuint -> IO String
getStringi GLuint
GL_EXTENSIONS
else String -> [String]
words forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GLuint -> IO String
getString GLuint
GL_EXTENSIONS
getVersion :: MonadIO m => m (Int, Int)
getVersion :: forall (m :: * -> *). MonadIO m => m (Int, Int)
getVersion = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO (GLuint -> IO String)
makeGetString 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 =
forall a. ReadP a -> a -> String -> a
runParser ReadP (Int, Int)
parseVersion (-Int
1, -Int
1) 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 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
String
_prefix <-
(String
"CL" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"OpenGL ES-CL ") forall a. ReadP a -> ReadP a -> ReadP a
<++
(String
"CM" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"OpenGL ES-CM ") forall a. ReadP a -> ReadP a -> ReadP a
<++
(String
"ES" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"OpenGL ES " ) forall a. ReadP a -> ReadP a -> ReadP a
<++
(String
"GL" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"" )
Int
major <- forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isDigit
Int
minor <- Char -> ReadP Char
char Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isDigit
String
_release <- (Char -> ReadP Char
char Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> ReadP String
munch1 (forall a. Eq a => a -> a -> Bool
/= Char
' ')) forall a. ReadP a -> ReadP a -> ReadP a
<++ forall (m :: * -> *) a. Monad m => a -> m a
return String
""
String
_vendorStuff <- (Char -> ReadP Char
char Char
' ' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Char
get forall a end. ReadP a -> ReadP end -> ReadP [a]
`manyTill` ReadP ()
eof) forall a. ReadP a -> ReadP a -> ReadP a
<++ (String
"" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP ()
eof)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
major, Int
minor)
makeGetString :: IO (GLenum -> IO String)
makeGetString :: IO (GLuint -> IO String)
makeGetString = do
GLuint -> IO (Ptr GLubyte)
glGetString_ <- FunPtr (GLuint -> IO (Ptr GLubyte)) -> GLuint -> IO (Ptr GLubyte)
dynGLenumIOPtrGLubyte forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
"glGetString"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \GLuint
name -> GLuint -> IO (Ptr GLubyte)
glGetString_ GLuint
name 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
GLuint -> GLuint -> IO (Ptr GLubyte)
glGetStringi_ <- FunPtr (GLuint -> GLuint -> IO (Ptr GLubyte))
-> GLuint -> GLuint -> IO (Ptr GLubyte)
dynGLenumGLuintIOPtrGLubyte forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
"glGetStringi"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \GLuint
name GLuint
index -> GLuint -> GLuint -> IO (Ptr GLubyte)
glGetStringi_ GLuint
name GLuint
index 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
GLuint -> Ptr GLint -> IO ()
glGetIntegerv_ <- FunPtr (GLuint -> Ptr GLint -> IO ())
-> GLuint -> Ptr GLint -> IO ()
dynGLenumPtrGLintIOVoid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => String -> m (FunPtr a)
getProcAddress String
"glGetIntegerv"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \GLuint
name -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr GLint
p -> GLuint -> Ptr GLint -> IO ()
glGetIntegerv_ GLuint
name Ptr GLint
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 = forall b a. b -> (Ptr a -> b) -> Ptr a -> b
ptr (forall (m :: * -> *) a. Monad m => a -> m a
return String
"") (CString -> IO String
peekUtf8String forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== 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 = forall a. ByteString -> (CString -> IO a) -> IO a
unsafeUseAsCString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
"\0")
peekUtf8String :: CString -> IO String
peekUtf8String :: CString -> IO String
peekUtf8String CString
p = Text -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 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 = forall a. IO a -> a
unsafePerformIO forall (m :: * -> *). MonadIO m => m (Set String)
getExtensions
{-# NOINLINE extensions #-}
version :: (Int, Int)
version :: (Int, Int)
version = forall a. IO a -> a
unsafePerformIO forall (m :: * -> *). MonadIO m => m (Int, Int)
getVersion
{-# NOINLINE version #-}