{-# LANGUAGE ForeignFunctionInterface, CPP #-}
--------------------------------------------------------------------------------
-- |
-- Copyright   :  (c) Edward Kmett and Gabríel Arthúr Pétursson 2014-2016, (c) Sven Panne 2013
-- License     :  BSD3
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module offers a portable way to retrieve OpenGL extension entries,
-- providing a portability layer upon platform-specific mechanisms like
-- @glXGetProcAddress@, @wglGetProcAddress@ or @NSAddressOfSymbol@.
--
-- This internal module offers convenience functions and re-exports for OpenGL
-- extension loading.
--
--------------------------------------------------------------------------------

module Graphics.GL.Internal.Proc
  ( getProcAddress
  , Invoker
  , extensions
  ) where

import Control.Monad
#if __GLASGOW_HASKELL__ < 710
import Data.Functor
#endif
import Data.Set as Set
import Foreign.C.String
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import Graphics.GL.Internal.FFI
  ( ffienumIOPtrubyte
  , ffienumuintIOPtrubyte
  , ffienumPtrintIOV
  )
import System.IO.Unsafe

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

-- | Retrieve an OpenGL extension entry by name. Returns 'nullFunPtr' when no
-- extension entry with the given name was found.
getProcAddress :: String -> IO (FunPtr a)
getProcAddress :: String -> IO (FunPtr a)
getProcAddress extensionEntry :: String
extensionEntry =
  String -> (CString -> IO (FunPtr a)) -> IO (FunPtr a)
forall a. String -> (CString -> IO a) -> IO a
withCString String
extensionEntry CString -> IO (FunPtr a)
forall a. CString -> IO (FunPtr a)
hs_gl_getProcAddress

foreign import ccall unsafe "hs_gl_getProcAddress"
  hs_gl_getProcAddress :: CString -> IO (FunPtr a)

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

type Invoker a = FunPtr a -> a

extensions :: Set String
extensions :: Set String
extensions = IO (Set String) -> Set String
forall a. IO a -> a
unsafePerformIO (IO (Set String) -> Set String) -> IO (Set String) -> Set String
forall a b. (a -> b) -> a -> b
$ do
  -- glGetStringi is only present in OpenGL 3.0 and OpenGL ES 3.0, and newer.
  FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte))
glGetStringiFunPtr <- String -> IO (FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte)))
forall a. String -> IO (FunPtr a)
getProcAddress "glGetStringi"
  if FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte))
glGetStringiFunPtr FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte))
-> FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte)) -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte))
forall a. FunPtr a
nullFunPtr then do
    GLenum -> IO (Ptr GLubyte)
glGetString <- FunPtr (GLenum -> IO (Ptr GLubyte)) -> GLenum -> IO (Ptr GLubyte)
forall (m :: * -> *).
MonadIO m =>
FunPtr (GLenum -> IO (Ptr GLubyte)) -> GLenum -> m (Ptr GLubyte)
ffienumIOPtrubyte (FunPtr (GLenum -> IO (Ptr GLubyte)) -> GLenum -> IO (Ptr GLubyte))
-> IO (FunPtr (GLenum -> IO (Ptr GLubyte)))
-> IO (GLenum -> IO (Ptr GLubyte))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (FunPtr (GLenum -> IO (Ptr GLubyte)))
forall a. String -> IO (FunPtr a)
getProcAddress "glGetString"
    String
supported <- GLenum -> IO (Ptr GLubyte)
glGetString 0x1F03 IO (Ptr GLubyte) -> (Ptr GLubyte -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString (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
    Set String -> IO (Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set String -> IO (Set String)) -> Set String -> IO (Set String)
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList (String -> [String]
words String
supported)
  else do
    let glGetStringi :: GLenum -> GLenum -> IO (Ptr GLubyte)
glGetStringi = FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte))
-> GLenum -> GLenum -> IO (Ptr GLubyte)
forall (m :: * -> *).
MonadIO m =>
FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte))
-> GLenum -> GLenum -> m (Ptr GLubyte)
ffienumuintIOPtrubyte FunPtr (GLenum -> GLenum -> IO (Ptr GLubyte))
glGetStringiFunPtr
    GLenum -> Ptr GLint -> IO ()
glGetIntegerv <- FunPtr (GLenum -> Ptr GLint -> IO ())
-> GLenum -> Ptr GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
FunPtr (GLenum -> Ptr GLint -> IO ())
-> GLenum -> Ptr GLint -> m ()
ffienumPtrintIOV (FunPtr (GLenum -> Ptr GLint -> IO ())
 -> GLenum -> Ptr GLint -> IO ())
-> IO (FunPtr (GLenum -> Ptr GLint -> IO ()))
-> IO (GLenum -> Ptr GLint -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (FunPtr (GLenum -> Ptr GLint -> IO ()))
forall a. String -> IO (FunPtr a)
getProcAddress "glGetIntegerv"
    GLint
numExtensions <- (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
$ \p :: Ptr GLint
p -> GLenum -> Ptr GLint -> IO ()
glGetIntegerv 0x821D Ptr GLint
p IO () -> IO GLint -> IO GLint
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
    [String]
supported <- [GLenum] -> (GLenum -> IO String) -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0..GLint -> GLenum
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
numExtensionsGLenum -> GLenum -> GLenum
forall a. Num a => a -> a -> a
-1] ((GLenum -> IO String) -> IO [String])
-> (GLenum -> IO String) -> IO [String]
forall a b. (a -> b) -> a -> b
$ GLenum -> GLenum -> IO (Ptr GLubyte)
glGetStringi 0x1F03 (GLenum -> IO (Ptr GLubyte))
-> (Ptr GLubyte -> IO String) -> GLenum -> IO String
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> CString -> IO String
peekCString (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
    Set String -> IO (Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set String -> IO (Set String)) -> Set String -> IO (Set String)
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
supported
{-# NOINLINE extensions #-}