{-# LANGUAGE CPP #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.StringQueries
-- Copyright   :  (c) Sven Panne 2002-2019
-- License     :  BSD3
-- 
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to parts of section 6.1.5 (String Queries) of the
-- OpenGL 3.2 specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.StringQueries (
   vendor, renderer, glVersion, glExtensions, extensionSupported,
   shadingLanguageVersion, majorMinor, ContextProfile'(..), contextProfile
) where

import Data.Bits
import Data.Char
#if !MIN_VERSION_base(4,8,0)
import Data.Functor( (<$>), (<$) )
#endif
import Data.Set ( member, toList )
import Data.StateVar as S
import Graphics.Rendering.OpenGL.GL.ByteString
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.GL
import Text.ParserCombinators.ReadP as R

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

vendor :: GettableStateVar String
vendor :: GettableStateVar String
vendor = GLenum -> GettableStateVar String
makeStringVar GLenum
GL_VENDOR

renderer :: GettableStateVar String
renderer :: GettableStateVar String
renderer = GLenum -> GettableStateVar String
makeStringVar GLenum
GL_RENDERER

glVersion :: GettableStateVar String
glVersion :: GettableStateVar String
glVersion = GLenum -> GettableStateVar String
makeStringVar GLenum
GL_VERSION

glExtensions :: GettableStateVar [String]
glExtensions :: GettableStateVar [String]
glExtensions = GettableStateVar [String] -> GettableStateVar [String]
forall a. IO a -> IO a
makeGettableStateVar (Set String -> [String]
forall a. Set a -> [a]
toList (Set String -> [String])
-> IO (Set String) -> GettableStateVar [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Set String)
forall (m :: * -> *). MonadIO m => m (Set String)
getExtensions)

extensionSupported :: String -> GettableStateVar Bool
extensionSupported :: String -> GettableStateVar Bool
extensionSupported String
ext =
  GettableStateVar Bool -> GettableStateVar Bool
forall a. IO a -> IO a
makeGettableStateVar (IO (Set String)
forall (m :: * -> *). MonadIO m => m (Set String)
getExtensions IO (Set String)
-> (Set String -> GettableStateVar Bool) -> GettableStateVar Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> GettableStateVar Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> GettableStateVar Bool)
-> (Set String -> Bool) -> Set String -> GettableStateVar Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
member String
ext))

shadingLanguageVersion :: GettableStateVar String
shadingLanguageVersion :: GettableStateVar String
shadingLanguageVersion = GLenum -> GettableStateVar String
makeStringVar GLenum
GL_SHADING_LANGUAGE_VERSION

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

data ContextProfile'
   = CoreProfile'
   | CompatibilityProfile'
   deriving ( ContextProfile' -> ContextProfile' -> Bool
(ContextProfile' -> ContextProfile' -> Bool)
-> (ContextProfile' -> ContextProfile' -> Bool)
-> Eq ContextProfile'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContextProfile' -> ContextProfile' -> Bool
$c/= :: ContextProfile' -> ContextProfile' -> Bool
== :: ContextProfile' -> ContextProfile' -> Bool
$c== :: ContextProfile' -> ContextProfile' -> Bool
Eq, Eq ContextProfile'
Eq ContextProfile'
-> (ContextProfile' -> ContextProfile' -> Ordering)
-> (ContextProfile' -> ContextProfile' -> Bool)
-> (ContextProfile' -> ContextProfile' -> Bool)
-> (ContextProfile' -> ContextProfile' -> Bool)
-> (ContextProfile' -> ContextProfile' -> Bool)
-> (ContextProfile' -> ContextProfile' -> ContextProfile')
-> (ContextProfile' -> ContextProfile' -> ContextProfile')
-> Ord ContextProfile'
ContextProfile' -> ContextProfile' -> Bool
ContextProfile' -> ContextProfile' -> Ordering
ContextProfile' -> ContextProfile' -> ContextProfile'
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ContextProfile' -> ContextProfile' -> ContextProfile'
$cmin :: ContextProfile' -> ContextProfile' -> ContextProfile'
max :: ContextProfile' -> ContextProfile' -> ContextProfile'
$cmax :: ContextProfile' -> ContextProfile' -> ContextProfile'
>= :: ContextProfile' -> ContextProfile' -> Bool
$c>= :: ContextProfile' -> ContextProfile' -> Bool
> :: ContextProfile' -> ContextProfile' -> Bool
$c> :: ContextProfile' -> ContextProfile' -> Bool
<= :: ContextProfile' -> ContextProfile' -> Bool
$c<= :: ContextProfile' -> ContextProfile' -> Bool
< :: ContextProfile' -> ContextProfile' -> Bool
$c< :: ContextProfile' -> ContextProfile' -> Bool
compare :: ContextProfile' -> ContextProfile' -> Ordering
$ccompare :: ContextProfile' -> ContextProfile' -> Ordering
$cp1Ord :: Eq ContextProfile'
Ord, Int -> ContextProfile' -> ShowS
[ContextProfile'] -> ShowS
ContextProfile' -> String
(Int -> ContextProfile' -> ShowS)
-> (ContextProfile' -> String)
-> ([ContextProfile'] -> ShowS)
-> Show ContextProfile'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContextProfile'] -> ShowS
$cshowList :: [ContextProfile'] -> ShowS
show :: ContextProfile' -> String
$cshow :: ContextProfile' -> String
showsPrec :: Int -> ContextProfile' -> ShowS
$cshowsPrec :: Int -> ContextProfile' -> ShowS
Show )

marshalContextProfile' :: ContextProfile' -> GLbitfield
marshalContextProfile' :: ContextProfile' -> GLenum
marshalContextProfile' ContextProfile'
x = case ContextProfile'
x of
   ContextProfile'
CoreProfile' -> GLenum
GL_CONTEXT_CORE_PROFILE_BIT
   ContextProfile'
CompatibilityProfile' -> GLenum
GL_CONTEXT_COMPATIBILITY_PROFILE_BIT

contextProfile :: GettableStateVar [ContextProfile']
contextProfile :: GettableStateVar [ContextProfile']
contextProfile = GettableStateVar [ContextProfile']
-> GettableStateVar [ContextProfile']
forall a. IO a -> IO a
makeGettableStateVar ((GLint -> [ContextProfile'])
-> PName1I -> GettableStateVar [ContextProfile']
forall p a. GetPName1I p => (GLint -> a) -> p -> IO a
getInteger1 GLint -> [ContextProfile']
i2cps PName1I
GetContextProfileMask)

i2cps :: GLint -> [ContextProfile']
i2cps :: GLint -> [ContextProfile']
i2cps GLint
bitfield =
   [ ContextProfile'
c | ContextProfile'
c <- [ ContextProfile'
CoreProfile', ContextProfile'
CompatibilityProfile' ]
       , (GLint -> GLenum
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
bitfield GLenum -> GLenum -> GLenum
forall a. Bits a => a -> a -> a
.&. ContextProfile' -> GLenum
marshalContextProfile' ContextProfile'
c) GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
/= GLenum
0 ]

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

makeStringVar :: GLenum -> GettableStateVar String
makeStringVar :: GLenum -> GettableStateVar String
makeStringVar = GettableStateVar String -> GettableStateVar String
forall a. IO a -> IO a
makeGettableStateVar (GettableStateVar String -> GettableStateVar String)
-> (GLenum -> GettableStateVar String)
-> GLenum
-> GettableStateVar String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Ptr GLubyte) -> GettableStateVar String
getStringWith (IO (Ptr GLubyte) -> GettableStateVar String)
-> (GLenum -> IO (Ptr GLubyte))
-> GLenum
-> GettableStateVar String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLenum -> IO (Ptr GLubyte)
forall (m :: * -> *). MonadIO m => GLenum -> m (Ptr GLubyte)
glGetString

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

-- | A utility function to be used with e.g. 'glVersion' or
-- 'shadingLanguageVersion', transforming a variable containing a string of the
-- form /major.minor[optional rest]/ into a variable containing a numeric
-- major\/minor version. If the string is malformed, which should never happen
-- with a sane OpenGL implementation, it is transformed to @(-1,-1)@.

majorMinor :: GettableStateVar String -> GettableStateVar (Int, Int)
majorMinor :: GettableStateVar String -> GettableStateVar (Int, Int)
majorMinor =
  GettableStateVar (Int, Int) -> GettableStateVar (Int, Int)
forall a. IO a -> IO a
makeGettableStateVar (GettableStateVar (Int, Int) -> GettableStateVar (Int, Int))
-> (GettableStateVar String -> GettableStateVar (Int, Int))
-> GettableStateVar String
-> GettableStateVar (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
-> GettableStateVar String -> GettableStateVar (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (GettableStateVar String -> GettableStateVar (Int, Int))
-> (GettableStateVar String -> GettableStateVar String)
-> GettableStateVar String
-> GettableStateVar (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GettableStateVar String -> GettableStateVar String
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
S.get

--------------------------------------------------------------------------------
-- Copy from Graphics.Rendering.OpenGL.Raw.GetProcAddress... :-/

runParser :: ReadP a -> a -> String -> a
runParser :: 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

-- 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" String -> ReadP String -> ReadP String
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
<++  -- OpenGL ES 1.x Common-Lite
    (String
"CM" String -> ReadP String -> ReadP String
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
<++  -- OpenGL ES 1.x Common
    (String
"ES" String -> ReadP String -> ReadP String
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
<++  -- OpenGL ES 2.x or 3.x
    (String
"GL" String -> ReadP String -> ReadP String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
""             )      -- OpenGL
  Int
major <- String -> Int
forall a. Read a => String -> a
read (String -> Int) -> ReadP String -> ReadP Int
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
'.' ReadP Char -> ReadP Int -> ReadP Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Int
forall a. Read a => String -> a
read (String -> Int) -> ReadP String -> ReadP Int
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
'.' ReadP Char -> ReadP String -> ReadP String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> ReadP String
munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')) ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ String -> ReadP String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
  String
_vendorStuff <- (Char -> ReadP Char
char Char
' ' ReadP Char -> ReadP String -> ReadP String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Char
R.get ReadP Char -> ReadP () -> ReadP String
forall a end. ReadP a -> ReadP end -> ReadP [a]
`manyTill` ReadP ()
eof) ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ (String
"" String -> ReadP () -> ReadP String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP ()
eof)
  (Int, Int) -> ReadP (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
major, Int
minor)