{-# LANGUAGE CPP #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.GL.GetProcAddress
-- Copyright   :  (c) Sven Panne 2009-2019
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module offers a portable way to retrieve OpenGL functions and extension
-- entries, providing a portability layer upon platform-specific mechanisms
-- like @glXGetProcAddress@, @wglGetProcAddress@ or @NSAddressOfSymbol@.
--
-- Note that /finding/ an OpenGL entry point doesn't mean that it's actually
-- /usable:/ On most platforms entry points are context-independent, so you have
-- to check the available extensions and\/or OpenGL version, too.
--------------------------------------------------------------------------------

module Graphics.GL.GetProcAddress (
   -- * Unchecked retrieval
   getProcAddress,
   getProcAddressWithSuffixes,
   getExtension,
   -- * Checked retrieval
   getProcAddressChecked,
   getProcAddressWithSuffixesChecked,
   getExtensionChecked,
   -- * Version info and extensions
   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

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

-- | Retrieve an OpenGL function by name. Returns 'nullFunPtr' when no function
-- with the given name was found.
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)

-- | Retrieve an OpenGL function by name. Throws an 'userError' when no function
-- with the given name was found.
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

-- | Retrieve an OpenGL function by name, trying a list of name suffixes in the
-- given order. Returns 'nullFunPtr' when no function with the given name plus
-- any of the suffixes was found.
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

-- | Retrieve an OpenGL function by name, trying a list of name suffixes in the
-- given order. Throws an 'userError' when no function with the given name plus
-- any of the suffixes was found.
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

-- | Retrieve an OpenGL function by name, additionally trying a list of all
-- known vendor suffixes. Returns 'nullFunPtr' when no function with the given
-- name plus any of the suffixes was found.
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

-- | Retrieve an OpenGL function by name, additionally trying a list of all
-- known vendor suffixes. Throws an 'userError' when no function with the given
-- name plus any of the suffixes was found.
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]
++)

-- This should really live in Foreign.Marshal.Error.
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 = [
   -- stuff already in the standard
   String
"",
   -- officially blessed stuff
   String
"ARB", String
"KHR", String
"OES",
   -- almost official stuff
   String
"EXT",
   -- random vendor stuff in decreasing order of number of extensions
   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" ]

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

-- | Retrieve the set of all available OpenGL extensions.
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
  -- glGetStringi is only present from OpenGL 3.0 and OpenGL ES 3.0 onwards, but
  -- we can't simply retrieve its entry point and check that against nullFunPtr:
  -- Apart from WGL, entry points are context-independent, so even having an
  -- entry point which looks valid doesn't guarantee that it is actually
  -- supported. Therefore we need to check the OpenGL version number directly.
  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

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

-- | Retrieve the OpenGL version, split into major and minor version numbers.
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

-- This does quite a bit more than we need for "normal" OpenGL, but at least it
-- documents the convoluted format of the version string in detail.
parseVersion :: ReadP (Int, Int)
parseVersion :: ReadP (Int, Int)
parseVersion = do
  String
_prefix <-
    -- Too lazy to define a type for the API...
    (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
<++  -- OpenGL ES 1.x Common-Lite
    (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
<++  -- OpenGL ES 1.x Common
    (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
<++  -- OpenGL ES 2.x or 3.x
    (String
"GL" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
""             )      -- OpenGL
  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)

--------------------------------------------------------------------------------
-- Graphics.GL.Foreign uses generated names, which are not
-- easily predictable, so we duplicate a few "foreign import"s below.

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 ()

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

-- Play safe, this is in line with OpenGL: Return something, but don't crash.
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)

-- This should really be in Foreign.Ptr.
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

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

-- | The set of all available OpenGL extensions. Note that in the presence of
-- multiple contexts with different capabilities, this might be wrong. Use
-- 'getExtensions' in those cases instead.
extensions :: Set String
extensions :: Set String
extensions = forall a. IO a -> a
unsafePerformIO forall (m :: * -> *). MonadIO m => m (Set String)
getExtensions
{-# NOINLINE extensions #-}

-- | The OpenGL version, split into major and minor version numbers. Note that
-- in the presence of multiple contexts with different capabilities, this might
-- be wrong. Use 'getVersion' in those cases instead.
version :: (Int, Int)
version :: (Int, Int)
version = forall a. IO a -> a
unsafePerformIO forall (m :: * -> *). MonadIO m => m (Int, Int)
getVersion
{-# NOINLINE version #-}