module Graphics.OpenGLES.Internal where
import Control.Applicative
import Control.Monad
import Control.Concurrent.Chan
import Control.Future
import Data.Array.Storable (StorableArray)
import qualified Data.ByteString as B
import Data.IORef
import Data.Typeable
import Foreign hiding (newForeignPtr, addForeignPtrFinalizer, void)
import Foreign.C.String (peekCString, peekCStringLen)
import Foreign.Concurrent (newForeignPtr, addForeignPtrFinalizer)
import Graphics.OpenGLES.Base
import Linear.Vect
import System.IO.Unsafe (unsafePerformIO)
errorQueue :: Chan String
errorQueue = unsafePerformIO newChan
glLog :: String -> IO ()
glLog msg = writeChan errorQueue msg
data GLError = InvalidEnum | InvalidValue | InvalidOperation
| OutOfMemory | InvalidFrameBufferOperation
deriving Show
getError :: GL (Maybe GLError)
getError = unMarshal <$> glGetError
where unMarshal x = case x of
0x0000 -> Nothing
0x0500 -> Just InvalidEnum
0x0501 -> Just InvalidValue
0x0502 -> Just InvalidOperation
0x0505 -> Just OutOfMemory
0x0506 -> Just InvalidFrameBufferOperation
showError :: String -> GL Bool
showError location = do
putStrLn location
getError >>= maybe (return False)
(\err -> do
glLog ("E " ++ location ++ ": " ++ show err)
return True )
type GLO = IORef (GLuint, ForeignPtr GLuint)
instance Show GLO where
show ref = show . unsafePerformIO $ readIORef ref
newGLO
:: (GLsizei -> Ptr GLuint -> GL ())
-> (GLuint -> GL ())
-> (GLsizei -> Ptr GLuint -> GL ())
-> GL GLO
newGLO gen bind del = do
ref <- newIORef undefined
genObj ref gen bind del
return ref
genObj
:: GLO
-> (GLsizei -> Ptr GLuint -> GL ())
-> (GLuint -> GL ())
-> (GLsizei -> Ptr GLuint -> GL ())
-> GL GLuint
genObj ref genObjs bindObj delObjs = do
fp <- mallocForeignPtr
withForeignPtr fp $ \ptr -> do
genObjs 1 ptr
showError "genObj"
obj <- peek ptr
writeIORef ref (obj, fp)
addForeignPtrFinalizer fp $ do
(obj, _) <- readIORef ref
with obj $ \ptr -> do
delObjs 1 ptr
void $ showError "delObj"
bindObj obj
return obj
data Buffer a =
Buffer BufferUsage GLO (IORef (StorableArray Int a))
newtype BufferUsage = BufferUsage GLenum
newtype BufferSlot = BufferSlot GLenum
newBuffer = newGLO glGenBuffers (glBindBuffer 0x8892) glDeleteBuffers
newtype DrawMode = DrawMode GLenum
newtype Capability = Capability GLenum
newtype CullFace = Culling GLenum
newtype CompFunc = CompFunc GLenum
newtype StencilOp = StencilOp GLenum
newtype BlendOp = BlendOp GLenum
newtype BlendingFactor = BlendingFactor GLenum
newtype Hint = Hint GLenum
type ShaderType = GLenum
data Shader = Shader ShaderType GLName B.ByteString
deriving Show
data TransformFeedback =
NoFeedback
| FeedbackArrays [String]
| FeedbackPacked [String]
deriving Show
data Program p = Program
{ programGLO :: GLO
, programTF :: TransformFeedback
, programShaders :: [Shader]
, programVariables :: ([VarDesc], [VarDesc])
} deriving Show
type ProgramBinary = B.ByteString
type VarDesc = (String, (GLint, GLsizei, GLenum))
programDict :: IORef [(String, Program ())]
programDict = unsafePerformIO $ newIORef []
lookupVarDesc :: TypeRep -> IO (Maybe ([VarDesc], [VarDesc]))
lookupVarDesc rep = do
let name = show rep
entry <- lookup name <$> readIORef programDict
case entry of
Nothing -> do
glLog $ "Program '" ++ name ++ "' is not compiled."
return Nothing
Just prog -> return $ Just (programVariables prog)
loadProgram
:: Typeable p
=> Program p
-> (Int -> String -> Maybe ProgramBinary -> GL ())
-> GL (Progress [String] (Program p))
loadProgram prog@(Program glo tf shaders ([],[])) progressLogger = do
let numShaders = length shaders
let progname = show (typeRep prog)
let msg = "Start compiling: " ++ progname
glLog msg
progressLogger 0 msg Nothing
pid <- glCreateProgram
res <- if pid == 0 then do
showError "glCreateProgram"
let msg = "Fatal: glCreateProgram returned 0."
progressLogger (numShaders + 1) msg Nothing
return $ Fixme [msg]
else do
results <- mapM (loadShader progressLogger) (zip [1..] shaders)
let errors = [msg | Fixme [msg] <- results]
res <- if errors /= []
then return $ Fixme errors
else do
forM_ results $ \(Finished sid) -> do
glAttachShader pid sid
showError "glAttachShader"
glLinkProgram pid
showError "glLinkProgram"
postLink progname numShaders prog pid progressLogger
sequence_ [glDeleteShader s | Finished s <- results]
return res
glLog "---------------"
return res
postLink
:: Typeable p
=> String -> Int -> Program p -> GLuint
-> (Int -> String -> Maybe ProgramBinary -> GL ())
-> GL (Progress [String] (Program p))
postLink progname numShaders prog pid
progressLogger = alloca $ \intptr -> do
glGetProgramiv pid c_link_status intptr
linkStatus <- peek intptr
glGetProgramiv pid c_info_log_length intptr
len <- fmap fromIntegral $ peek intptr
info <- allocaBytes len $ \buf -> do
glGetProgramInfoLog pid (fromIntegral len) nullPtr buf
peekCStringLen (buf, len1)
let info' = if info == "" then "" else '\n':info
if linkStatus == 0 then do
let msg = "Cannot link program " ++ progname ++ info'
glLog msg
progressLogger (numShaders + 1) msg Nothing
glDeleteProgram pid
return $ Fixme [msg]
else do
vars <- getActiveVariables pid
putStrLn . show $ vars
fp <- newForeignPtr nullPtr (glDeleteProgram pid)
writeIORef (programGLO prog) (pid, fp)
let msg = "Successfully linked " ++ progname ++ "!" ++ info'
glLog msg
progressLogger (numShaders + 1) msg Nothing
let prog' = prog { programVariables = vars }
atomicModifyIORef' programDict $! \xs ->
((show (typeRep prog), prog'):xs, ())
return $ Finished prog'
c_link_status = 0x8B82
c_info_log_length = 0x8B84
loadShader
:: (Int -> String -> Maybe ProgramBinary -> GL ())
-> (Int, Shader)
-> GL (Progress [String] GLuint)
loadShader progressLogger (i, Shader shaderType name bs) = do
sid <- glCreateShader shaderType
if sid == 0 then do
showError "glCreateShader"
let msg = "Fatal: glCreateShader returned 0."
glLog msg
progressLogger i msg Nothing
return $ Fixme [name ++ ": " ++ msg]
else B.useAsCString bs $ \src -> do
withArray [src] $ \ptr -> do
glShaderSource sid 1 ptr nullPtr
showError "glShaderSource"
glCompileShader sid
showError "glCompileShader"
alloca $ \pint -> do
glGetShaderiv sid c_compile_status pint
compiled <- peek pint
glGetShaderiv sid c_info_log_length pint
len <- fmap fromIntegral $ peek pint
info <- allocaBytes len $ \buf -> do
glGetShaderInfoLog sid (fromIntegral len) nullPtr buf
peekCStringLen (buf, len1)
let info' = if info == "" then "" else '\n':info
if compiled == 0 then do
let msg = "Could not compile " ++ name ++ info'
glLog msg
progressLogger i msg Nothing
glDeleteShader sid
return $ Fixme [msg]
else do
let msg = name ++ " ... done" ++ info'
glLog msg
progressLogger i msg Nothing
return $ Finished sid
c_compile_status = 0x8B81
getActiveVariables :: GLuint -> GL ([VarDesc], [VarDesc])
getActiveVariables pid = do
sptr <- malloc
glGetProgramiv pid c_active_uniform_max_length sptr
uMaxLen <- peek sptr
glGetProgramiv pid c_active_attribute_max_length sptr
aMaxLen <- peek sptr
let maxlen = max uMaxLen aMaxLen
str <- mallocBytes (fromIntegral maxlen)
glGetProgramiv pid c_active_uniforms sptr
numU <- peek sptr
glGetProgramiv pid c_active_attributes sptr
numA <- peek sptr
tptr <- malloc
uniforms <- forM [0..numU1] $ \ index -> do
let i = (fromIntegral :: GLint -> GLuint) index
glGetActiveUniform pid i maxlen nullPtr sptr tptr str
name <- peekCString str
loc <- glGetUniformLocation pid str
size <- peek sptr
typ <- peek tptr
return (name, (loc, size, typ))
attribs <- forM [0..numA1] $ \index -> do
let i = fromIntegral index
glGetActiveAttrib pid i maxlen nullPtr sptr tptr str
name <- peekCString str
loc <- glGetAttribLocation pid str
size <- peek sptr
typ <- peek tptr
putStrLn . show $ (index, loc)
return (name, (loc, size, typ))
free str; free sptr; free tptr
return (uniforms, attribs)
c_active_uniform_max_length = 0x8B87
c_active_attribute_max_length = 0x8B8A
c_active_uniforms = 0x8B86
c_active_attributes = 0x8B89
newtype Uniform p a = Uniform (GLint, GLsizei, Ptr ())
class UnifVal a where
glUniform :: (GLint, GLsizei, Ptr ()) -> a -> GL ()
newtype Attrib p a = Attrib (GLuint, GLsizei, GLboolean, GLuint) deriving Show
class (Num a, Storable a) => GenericVertexAttribute a where
glVertexAttrib4v :: GLuint -> Ptr (V4 a) -> GL ()
instance GenericVertexAttribute Float where
glVertexAttrib4v idx = glVertexAttrib4fv idx . castPtr
instance GenericVertexAttribute Int32 where
glVertexAttrib4v idx = glVertexAttribI4iv idx . castPtr
instance GenericVertexAttribute Word32 where
glVertexAttrib4v idx = glVertexAttribI4uiv idx . castPtr
class ShaderAttribute a where
glVertexAttrib :: GLuint -> a -> GL ()
class Storable b => AttrStruct b a p | a -> p where
glVertexAttribPtr :: a -> Buffer b -> GL ()
newtype VertexArray p = VertexArray (GLO, GL ())
newtype HalfFloat = HalfFloat Word16 deriving (Num,Read,Show,Storable)
newtype FixedFloat = FixedFloat Int32 deriving (Num,Read,Show,Storable)
newtype Int10x3_2 = Int10x3_2 Int32 deriving (Num,Read,Show,Storable)
newtype Word10x3_2 = Word10x3_2 Int32 deriving (Num,Read,Show,Storable)
class GLType a where
glType :: m a -> Word32
instance GLType Int8 where glType _ = 0x1400
instance GLType Word8 where glType _ = 0x1401
instance GLType Int16 where glType _ = 0x1402
instance GLType Word16 where glType _ = 0x1403
instance GLType Int32 where glType _ = 0x1404
instance GLType Word32 where glType _ = 0x1405
instance GLType Float where glType _ = 0x1406
instance GLType HalfFloat where glType _ = 0x140B
instance GLType FixedFloat where glType _ = 0x140C
instance GLType Int10x3_2 where glType _ = 0x8D9F
instance GLType Word10x3_2 where glType _ = 0x8368
newtype VertexPicker = VertexPicker (GLenum -> GL Bool)
class VertexIx a where
vxix :: m a -> (GLenum, GLint)
instance VertexIx Word8 where
vxix = const (0x1401, 1)
instance VertexIx Word16 where
vxix = const (0x1403, 2)
instance VertexIx Word32 where
vxix = const (0x1405, 4)
newtype ClearBufferMask = ClearBufferMask GLenum deriving Num
drawOrExit :: IORef (Maybe (GL ()))
drawOrExit = unsafePerformIO $ newIORef Nothing
drawQueue :: Chan (GL ())
drawQueue = unsafePerformIO newChan