{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
module Typograffiti.GL where

import           Control.Exception      (assert)
import           Control.Monad          (forM_, replicateM, when)
import           Control.Monad.Fail     (MonadFail)
import           Control.Monad.IO.Class (MonadIO (..))
import           Data.ByteString        (ByteString)
import qualified Data.ByteString.Char8  as B8
import qualified Data.Foldable          as F
import qualified Data.Vector.Storable   as SV
import           Data.Vector.Unboxed    (Unbox)
import qualified Data.Vector.Unboxed    as UV
import           Foreign.C.String       (peekCAStringLen, withCString)
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           GHC.TypeLits           (KnownNat)
import           Graphics.GL.Core32
import           Graphics.GL.Types
import           Linear
import           Linear.V               (Finite, Size, dim, toV)

-- | Allocates a new active texture (image data) in the GPU.
allocAndActivateTex :: (MonadIO m, MonadFail m) => GLenum -> m GLuint
allocAndActivateTex :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
GLenum -> m GLenum
allocAndActivateTex GLenum
u = do
  [GLenum
t] <- IO [GLenum] -> m [GLenum]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GLenum] -> m [GLenum]) -> IO [GLenum] -> m [GLenum]
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr GLenum -> IO [GLenum]) -> IO [GLenum]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
1 ((Ptr GLenum -> IO [GLenum]) -> IO [GLenum])
-> (Ptr GLenum -> IO [GLenum]) -> IO [GLenum]
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
ptr -> do
    GLsizei -> Ptr GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Ptr GLenum -> m ()
glGenTextures GLsizei
1 Ptr GLenum
ptr
    Int -> Ptr GLenum -> IO [GLenum]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 Ptr GLenum
ptr
  GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glActiveTexture GLenum
u
  GLenum -> GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glBindTexture GLenum
forall {a}. (Eq a, Num a) => a
GL_TEXTURE_2D GLenum
t
  GLenum -> m GLenum
forall (m :: * -> *) a. Monad m => a -> m a
return GLenum
t

-- | Report any exceptions encounted by OpenGL.
clearErrors :: MonadIO m => String -> m ()
clearErrors :: forall (m :: * -> *). MonadIO m => String -> m ()
clearErrors String
str = do
  GLenum
err' <- m GLenum
forall (m :: * -> *). MonadIO m => m GLenum
glGetError
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GLenum
err' GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
/= GLenum
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
str, GLenum -> String
forall a. Show a => a -> String
show GLenum
err']
    Bool -> m () -> m ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Allocates a new, bound Vertex Array Object.
newBoundVAO :: (MonadIO m, MonadFail m) => m GLuint
newBoundVAO :: forall (m :: * -> *). (MonadIO m, MonadFail m) => m GLenum
newBoundVAO = do
  [GLenum
vao] <- IO [GLenum] -> m [GLenum]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GLenum] -> m [GLenum]) -> IO [GLenum] -> m [GLenum]
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr GLenum -> IO [GLenum]) -> IO [GLenum]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
1 ((Ptr GLenum -> IO [GLenum]) -> IO [GLenum])
-> (Ptr GLenum -> IO [GLenum]) -> IO [GLenum]
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
ptr -> do
      GLsizei -> Ptr GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Ptr GLenum -> m ()
glGenVertexArrays GLsizei
1 Ptr GLenum
ptr
      Int -> Ptr GLenum -> IO [GLenum]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 Ptr GLenum
ptr
  GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBindVertexArray GLenum
vao
  GLenum -> m GLenum
forall (m :: * -> *) a. Monad m => a -> m a
return GLenum
vao


-- | Runs the given callback giving a new temporarily-bound Vertex Array Object,
-- catching any errors.
withVAO :: MonadIO m => (GLuint -> IO b) -> m b
withVAO :: forall (m :: * -> *) b. MonadIO m => (GLenum -> IO b) -> m b
withVAO GLenum -> IO b
f = IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ do
  GLenum
vao <- IO GLenum
forall (m :: * -> *). (MonadIO m, MonadFail m) => m GLenum
newBoundVAO
  b
r <- GLenum -> IO b
f GLenum
vao
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
clearErrors String
"withVAO"
  GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBindVertexArray GLenum
0
  b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r

-- | Allocates a new buffer on the GPU.
newBuffer
  :: MonadIO m
  => m GLuint
newBuffer :: forall (m :: * -> *). MonadIO m => m GLenum
newBuffer = IO GLenum -> m GLenum
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GLenum -> m GLenum) -> IO GLenum -> m GLenum
forall a b. (a -> b) -> a -> b
$ do
  [GLenum
b] <- Int -> (Ptr GLenum -> IO [GLenum]) -> IO [GLenum]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
1 ((Ptr GLenum -> IO [GLenum]) -> IO [GLenum])
-> (Ptr GLenum -> IO [GLenum]) -> IO [GLenum]
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
ptr -> do
    GLsizei -> Ptr GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Ptr GLenum -> m ()
glGenBuffers GLsizei
1 Ptr GLenum
ptr
    Int -> Ptr GLenum -> IO [GLenum]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 Ptr GLenum
ptr
  GLenum -> IO GLenum
forall (m :: * -> *) a. Monad m => a -> m a
return GLenum
b

-- Allocates the given number of buffer objects to pass to the given callback.
withBuffers :: MonadIO m => Int -> ([GLuint] -> m b) -> m b
withBuffers :: forall (m :: * -> *) b.
MonadIO m =>
Int -> ([GLenum] -> m b) -> m b
withBuffers Int
n = (Int -> m GLenum -> m [GLenum]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n m GLenum
forall (m :: * -> *). MonadIO m => m GLenum
newBuffer m [GLenum] -> ([GLenum] -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)


-- | Buffer some geometry into an attribute.
-- The type variable 'f' should be V0, V1, V2, V3 or V4.
bufferGeometry
  :: ( Foldable f
     , Unbox (f Float)
     , Storable (f Float)
     , Finite f
     , KnownNat (Size f)
     , MonadIO m
     )
  => GLuint
  -- ^ The attribute location.
  -> GLuint
  -- ^ The buffer identifier.
  -> UV.Vector (f Float)
  -- ^ The geometry to buffer.
  -> m ()
bufferGeometry :: forall (f :: * -> *) (m :: * -> *).
(Foldable f, Unbox (f Float), Storable (f Float), Finite f,
 KnownNat (Size f), MonadIO m) =>
GLenum -> GLenum -> Vector (f Float) -> m ()
bufferGeometry GLenum
loc GLenum
buf Vector (f Float)
as
  | Vector (f Float) -> Bool
forall a. Unbox a => Vector a -> Bool
UV.null Vector (f Float)
as = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
    let v :: f Float
v     = Vector (f Float) -> f Float
forall a. Unbox a => Vector a -> a
UV.head Vector (f Float)
as
        asize :: Int
asize = Vector (f Float) -> Int
forall a. Unbox a => Vector a -> Int
UV.length Vector (f Float)
as Int -> Int -> Int
forall a. Num a => a -> a -> a
* f Float -> Int
forall a. Storable a => a -> Int
sizeOf f Float
v
        n :: GLsizei
n     = Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLsizei) -> Int -> GLsizei
forall a b. (a -> b) -> a -> b
$ V (Size f) Float -> Int
forall {k} (n :: k) a. Dim n => V n a -> Int
dim (V (Size f) Float -> Int) -> V (Size f) Float -> Int
forall a b. (a -> b) -> a -> b
$ f Float -> V (Size f) Float
forall (v :: * -> *) a. Finite v => v a -> V (Size v) a
toV f Float
v
    GLenum -> GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glBindBuffer GLenum
forall {a}. (Eq a, Num a) => a
GL_ARRAY_BUFFER GLenum
buf
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Vector Float -> (Ptr Float -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
SV.unsafeWith (Vector (f Float) -> Vector Float
forall (f :: * -> *).
(Unbox (f Float), Foldable f) =>
Vector (f Float) -> Vector Float
convertVec Vector (f Float)
as) ((Ptr Float -> IO ()) -> IO ()) -> (Ptr Float -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Float
ptr ->
      GLenum -> GLsizeiptr -> Ptr () -> GLenum -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizeiptr -> Ptr () -> GLenum -> m ()
glBufferData GLenum
forall {a}. (Eq a, Num a) => a
GL_ARRAY_BUFFER (Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
asize) (Ptr Float -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr Float
ptr) GLenum
forall {a}. (Eq a, Num a) => a
GL_STATIC_DRAW
    GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glEnableVertexAttribArray GLenum
loc
    GLenum
-> GLsizei -> GLenum -> GLboolean -> GLsizei -> Ptr () -> m ()
forall (m :: * -> *).
MonadIO m =>
GLenum
-> GLsizei -> GLenum -> GLboolean -> GLsizei -> Ptr () -> m ()
glVertexAttribPointer GLenum
loc GLsizei
n GLenum
forall {a}. (Eq a, Num a) => a
GL_FLOAT GLboolean
forall {a}. (Eq a, Num a) => a
GL_FALSE GLsizei
0 Ptr ()
forall a. Ptr a
nullPtr
    String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
clearErrors String
"bufferGeometry"

-- | Converts an unboxed vector to a storable vector suitable for storing in a GPU buffer.
convertVec
  :: (Unbox (f Float), Foldable f) => UV.Vector (f Float) -> SV.Vector GLfloat
convertVec :: forall (f :: * -> *).
(Unbox (f Float), Foldable f) =>
Vector (f Float) -> Vector Float
convertVec =
  Vector Float -> Vector Float
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
SV.convert (Vector Float -> Vector Float)
-> (Vector (f Float) -> Vector Float)
-> Vector (f Float)
-> Vector Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float) -> Vector Float -> Vector Float
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
UV.map Float -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Vector Float -> Vector Float)
-> (Vector (f Float) -> Vector Float)
-> Vector (f Float)
-> Vector Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f Float -> Vector Float) -> Vector (f Float) -> Vector Float
forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
UV.concatMap ([Float] -> Vector Float
forall a. Unbox a => [a] -> Vector a
UV.fromList ([Float] -> Vector Float)
-> (f Float -> [Float]) -> f Float -> Vector Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Float -> [Float]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList)


-- | Binds the given textures to GL_TEXTURE0, GL_TEXTURE1, ... in ascending
-- order of the texture unit, runs the IO action and then unbinds the textures.
withBoundTextures :: MonadIO m => [GLuint] -> m a -> m a
withBoundTextures :: forall (m :: * -> *) a. MonadIO m => [GLenum] -> m a -> m a
withBoundTextures [GLenum]
ts m a
f = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ((GLenum, GLenum) -> IO ()) -> [(GLenum, GLenum)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((GLenum -> GLenum -> IO ()) -> (GLenum, GLenum) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry GLenum -> GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
bindTex) ([GLenum] -> [GLenum] -> [(GLenum, GLenum)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GLenum]
ts [GLenum
forall {a}. (Eq a, Num a) => a
GL_TEXTURE0 ..])
  a
a <- m a
f
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLenum -> GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glBindTexture GLenum
forall {a}. (Eq a, Num a) => a
GL_TEXTURE_2D GLenum
0
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  where bindTex :: GLenum -> GLenum -> m ()
bindTex GLenum
tex GLenum
u = GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glActiveTexture GLenum
u m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GLenum -> GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glBindTexture GLenum
forall {a}. (Eq a, Num a) => a
GL_TEXTURE_2D GLenum
tex


-- | Render the given slice of the given Vertex-Array Object with the given program
-- in the given mode, with exception handling.
drawVAO
  :: MonadIO m
  => GLuint
  -- ^ The program
  -> GLuint
  -- ^ The vao
  -> GLenum
  -- ^ The draw mode
  -> GLsizei
  -- ^ The number of vertices to draw
  -> m ()
drawVAO :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> GLenum -> GLsizei -> m ()
drawVAO GLenum
program GLenum
vao GLenum
mode GLsizei
num = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glUseProgram GLenum
program
  GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBindVertexArray GLenum
vao
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
clearErrors String
"drawBuffer:glBindVertex"
  GLenum -> GLsizei -> GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> GLsizei -> m ()
glDrawArrays GLenum
mode GLsizei
0 GLsizei
num
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
clearErrors String
"drawBuffer:glDrawArrays"

-- | Compiles GLSL code to GPU opcodes, or returns an error message.
compileOGLShader
  :: MonadIO m
  => ByteString
     -- ^ The shader source
  -> GLenum
  -- ^ The shader type (vertex, frag, etc)
  -> m (Either String GLuint)
  -- ^ Either an error message or the generated shader handle.
compileOGLShader :: forall (m :: * -> *).
MonadIO m =>
ByteString -> GLenum -> m (Either String GLenum)
compileOGLShader ByteString
src GLenum
shType = do
  GLenum
shader <- IO GLenum -> m GLenum
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GLenum -> m GLenum) -> IO GLenum -> m GLenum
forall a b. (a -> b) -> a -> b
$ GLenum -> IO GLenum
forall (m :: * -> *). MonadIO m => GLenum -> m GLenum
glCreateShader GLenum
shType
  if GLenum
shader GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
0
    then Either String GLenum -> m (Either String GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GLenum -> m (Either String GLenum))
-> Either String GLenum -> m (Either String GLenum)
forall a b. (a -> b) -> a -> b
$ String -> Either String GLenum
forall a b. a -> Either a b
Left String
"Could not create shader"
    else do
      GLsizei
success <- IO GLsizei -> m GLsizei
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GLsizei -> m GLsizei) -> IO GLsizei -> m GLsizei
forall a b. (a -> b) -> a -> b
$ do
        String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString (ByteString -> String
B8.unpack ByteString
src) ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
ptr ->
          CString -> (Ptr CString -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CString
ptr ((Ptr CString -> IO ()) -> IO ())
-> (Ptr CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CString
ptrptr -> GLenum -> GLsizei -> Ptr CString -> Ptr GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> Ptr CString -> Ptr GLsizei -> m ()
glShaderSource GLenum
shader GLsizei
1 Ptr CString
ptrptr Ptr GLsizei
forall a. Ptr a
nullPtr

        GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glCompileShader GLenum
shader
        GLsizei -> (Ptr GLsizei -> IO GLsizei) -> IO GLsizei
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (GLsizei
0 :: GLint) ((Ptr GLsizei -> IO GLsizei) -> IO GLsizei)
-> (Ptr GLsizei -> IO GLsizei) -> IO GLsizei
forall a b. (a -> b) -> a -> b
$ \Ptr GLsizei
ptr -> do
          GLenum -> GLenum -> Ptr GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> Ptr GLsizei -> m ()
glGetShaderiv GLenum
shader GLenum
forall {a}. (Eq a, Num a) => a
GL_COMPILE_STATUS Ptr GLsizei
ptr
          Ptr GLsizei -> IO GLsizei
forall a. Storable a => Ptr a -> IO a
peek Ptr GLsizei
ptr

      if GLsizei
success GLsizei -> GLsizei -> Bool
forall a. Eq a => a -> a -> Bool
== GLsizei
forall {a}. (Eq a, Num a) => a
GL_FALSE
        then do
          String
err <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ do
            [GLchar]
infoLog <- GLsizei -> (Ptr GLsizei -> IO [GLchar]) -> IO [GLchar]
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (GLsizei
0 :: GLint) ((Ptr GLsizei -> IO [GLchar]) -> IO [GLchar])
-> (Ptr GLsizei -> IO [GLchar]) -> IO [GLchar]
forall a b. (a -> b) -> a -> b
$ \Ptr GLsizei
ptr -> do
                GLenum -> GLenum -> Ptr GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> Ptr GLsizei -> m ()
glGetShaderiv GLenum
shader GLenum
forall {a}. (Eq a, Num a) => a
GL_INFO_LOG_LENGTH Ptr GLsizei
ptr
                GLsizei
logsize <- Ptr GLsizei -> IO GLsizei
forall a. Storable a => Ptr a -> IO a
peek Ptr GLsizei
ptr
                Int -> (CString -> IO [GLchar]) -> IO [GLchar]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
logsize) ((CString -> IO [GLchar]) -> IO [GLchar])
-> (CString -> IO [GLchar]) -> IO [GLchar]
forall a b. (a -> b) -> a -> b
$ \CString
logptr -> do
                    GLenum -> GLsizei -> Ptr GLsizei -> CString -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> Ptr GLsizei -> CString -> m ()
glGetShaderInfoLog GLenum
shader GLsizei
logsize Ptr GLsizei
forall a. Ptr a
nullPtr CString
logptr
                    Int -> CString -> IO [GLchar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
logsize) CString
logptr

            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"Could not compile shader:"
                             , ByteString -> String
B8.unpack ByteString
src
                             , (GLchar -> Char) -> [GLchar] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (GLchar -> Int) -> GLchar -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLchar -> Int
forall a. Enum a => a -> Int
fromEnum) [GLchar]
infoLog
                             ]
          Either String GLenum -> m (Either String GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GLenum -> m (Either String GLenum))
-> Either String GLenum -> m (Either String GLenum)
forall a b. (a -> b) -> a -> b
$ String -> Either String GLenum
forall a b. a -> Either a b
Left String
err
        else Either String GLenum -> m (Either String GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GLenum -> m (Either String GLenum))
-> Either String GLenum -> m (Either String GLenum)
forall a b. (a -> b) -> a -> b
$ GLenum -> Either String GLenum
forall a b. b -> Either a b
Right GLenum
shader

-- Combine multiple compiled GLSL shaders into a single program,
-- or returns an error message.
compileOGLProgram
  :: MonadIO m
  => [(String, Integer)]
  -> [GLuint]
  -> m (Either String GLuint)
compileOGLProgram :: forall (m :: * -> *).
MonadIO m =>
[(String, Integer)] -> [GLenum] -> m (Either String GLenum)
compileOGLProgram [(String, Integer)]
attribs [GLenum]
shaders = do
  (GLenum
program, GLsizei
success) <- IO (GLenum, GLsizei) -> m (GLenum, GLsizei)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (GLenum, GLsizei) -> m (GLenum, GLsizei))
-> IO (GLenum, GLsizei) -> m (GLenum, GLsizei)
forall a b. (a -> b) -> a -> b
$ do
     GLenum
program <- IO GLenum
forall (m :: * -> *). MonadIO m => m GLenum
glCreateProgram
     [GLenum] -> (GLenum -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GLenum]
shaders (GLenum -> GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glAttachShader GLenum
program)
     [(String, Integer)] -> ((String, Integer) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, Integer)]
attribs
       (((String, Integer) -> IO ()) -> IO ())
-> ((String, Integer) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
name, Integer
loc) ->
         String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
name
           ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLenum -> GLenum -> CString -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> CString -> m ()
glBindAttribLocation GLenum
program
           (GLenum -> CString -> IO ()) -> GLenum -> CString -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> GLenum
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
loc
     GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glLinkProgram GLenum
program

     GLsizei
success <- GLsizei -> (Ptr GLsizei -> IO GLsizei) -> IO GLsizei
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (GLsizei
0 :: GLint) ((Ptr GLsizei -> IO GLsizei) -> IO GLsizei)
-> (Ptr GLsizei -> IO GLsizei) -> IO GLsizei
forall a b. (a -> b) -> a -> b
$ \Ptr GLsizei
ptr -> do
       GLenum -> GLenum -> Ptr GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> Ptr GLsizei -> m ()
glGetProgramiv GLenum
program GLenum
forall {a}. (Eq a, Num a) => a
GL_LINK_STATUS Ptr GLsizei
ptr
       Ptr GLsizei -> IO GLsizei
forall a. Storable a => Ptr a -> IO a
peek Ptr GLsizei
ptr
     (GLenum, GLsizei) -> IO (GLenum, GLsizei)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLenum
program, GLsizei
success)

  if GLsizei
success GLsizei -> GLsizei -> Bool
forall a. Eq a => a -> a -> Bool
== GLsizei
forall {a}. (Eq a, Num a) => a
GL_FALSE
  then IO (Either String GLenum) -> m (Either String GLenum)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String GLenum) -> m (Either String GLenum))
-> IO (Either String GLenum) -> m (Either String GLenum)
forall a b. (a -> b) -> a -> b
$ GLsizei
-> (Ptr GLsizei -> IO (Either String GLenum))
-> IO (Either String GLenum)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (GLsizei
0 :: GLint) ((Ptr GLsizei -> IO (Either String GLenum))
 -> IO (Either String GLenum))
-> (Ptr GLsizei -> IO (Either String GLenum))
-> IO (Either String GLenum)
forall a b. (a -> b) -> a -> b
$ \Ptr GLsizei
ptr -> do
    GLenum -> GLenum -> Ptr GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> Ptr GLsizei -> m ()
glGetProgramiv GLenum
program GLenum
forall {a}. (Eq a, Num a) => a
GL_INFO_LOG_LENGTH Ptr GLsizei
ptr
    GLsizei
logsize <- Ptr GLsizei -> IO GLsizei
forall a. Storable a => Ptr a -> IO a
peek Ptr GLsizei
ptr
    [GLchar]
infoLog <- Int -> (CString -> IO [GLchar]) -> IO [GLchar]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
logsize) ((CString -> IO [GLchar]) -> IO [GLchar])
-> (CString -> IO [GLchar]) -> IO [GLchar]
forall a b. (a -> b) -> a -> b
$ \CString
logptr -> do
      GLenum -> GLsizei -> Ptr GLsizei -> CString -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> Ptr GLsizei -> CString -> m ()
glGetProgramInfoLog GLenum
program GLsizei
logsize Ptr GLsizei
forall a. Ptr a
nullPtr CString
logptr
      Int -> CString -> IO [GLchar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
logsize) CString
logptr
    Either String GLenum -> IO (Either String GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return
      (Either String GLenum -> IO (Either String GLenum))
-> Either String GLenum -> IO (Either String GLenum)
forall a b. (a -> b) -> a -> b
$ String -> Either String GLenum
forall a b. a -> Either a b
Left
      (String -> Either String GLenum) -> String -> Either String GLenum
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ String
"Could not link program"
          , (GLchar -> Char) -> [GLchar] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (GLchar -> Int) -> GLchar -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLchar -> Int
forall a. Enum a => a -> Int
fromEnum) [GLchar]
infoLog
          ]
  else do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [GLenum] -> (GLenum -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GLenum]
shaders GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glDeleteShader
    Either String GLenum -> m (Either String GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GLenum -> m (Either String GLenum))
-> Either String GLenum -> m (Either String GLenum)
forall a b. (a -> b) -> a -> b
$ GLenum -> Either String GLenum
forall a b. b -> Either a b
Right GLenum
program


--------------------------------------------------------------------------------
-- Uniform marshaling functions
--------------------------------------------------------------------------------

-- | Lookup ID for a named uniform GLSL variable.
getUniformLocation :: MonadIO m => GLuint -> String -> m GLint
getUniformLocation :: forall (m :: * -> *). MonadIO m => GLenum -> String -> m GLsizei
getUniformLocation GLenum
program String
ident = IO GLsizei -> m GLsizei
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  (IO GLsizei -> m GLsizei) -> IO GLsizei -> m GLsizei
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO GLsizei) -> IO GLsizei
forall a. String -> (CString -> IO a) -> IO a
withCString String
ident
  ((CString -> IO GLsizei) -> IO GLsizei)
-> (CString -> IO GLsizei) -> IO GLsizei
forall a b. (a -> b) -> a -> b
$ GLenum -> CString -> IO GLsizei
forall (m :: * -> *). MonadIO m => GLenum -> CString -> m GLsizei
glGetUniformLocation GLenum
program

-- | Data that can be uploaded to GLSL uniform variables.
class UniformValue a where
  -- | Upload a value to a GLSL uniform variable.
  updateUniform
    :: MonadIO m
    => GLuint
    -- ^ The program
    -> GLint
    -- ^ The uniform location
    -> a
    -- ^ The value.
    -> m ()

-- | Report exceptions setting GLSL uniform variables.
clearUniformUpdateError :: (MonadIO m, Show a) => GLuint -> GLint -> a -> m ()
clearUniformUpdateError :: forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
prog GLsizei
loc a
val = m GLenum
forall (m :: * -> *). MonadIO m => m GLenum
glGetError m GLenum -> (GLenum -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  GLenum
0 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  GLenum
e -> do
    let buf :: String
buf = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
256 Char
' '
    String
ident <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
buf
      ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \CString
strptr -> GLsizei -> (Ptr GLsizei -> IO String) -> IO String
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLsizei
0
      ((Ptr GLsizei -> IO String) -> IO String)
-> (Ptr GLsizei -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Ptr GLsizei
szptr  -> do
        GLenum -> GLenum -> GLsizei -> Ptr GLsizei -> CString -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> GLsizei -> Ptr GLsizei -> CString -> m ()
glGetActiveUniformName GLenum
prog (GLsizei -> GLenum
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
loc) GLsizei
256 Ptr GLsizei
szptr CString
strptr
        GLsizei
sz <- Ptr GLsizei -> IO GLsizei
forall a. Storable a => Ptr a -> IO a
peek Ptr GLsizei
szptr
        CStringLen -> IO String
peekCAStringLen (CString
strptr, GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
sz)
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn
      (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
          [ String
"Could not update uniform"
          , String
ident
          , String
"with value"
          , a -> String
forall a. Show a => a -> String
show a
val
          , String
", encountered error (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ GLenum -> String
forall a. Show a => a -> String
show GLenum
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
          , (Integer, String) -> String
forall a. Show a => a -> String
show (Integer
forall {a}. (Eq a, Num a) => a
GL_INVALID_OPERATION :: Integer, String
"invalid operation" :: String)
          , (Integer, String) -> String
forall a. Show a => a -> String
show (Integer
forall {a}. (Eq a, Num a) => a
GL_INVALID_VALUE :: Integer, String
"invalid value" :: String)
          ]
    Bool -> m () -> m ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


instance UniformValue Bool where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> Bool -> m ()
updateUniform GLenum
p GLsizei
loc Bool
bool = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    GLsizei -> GLsizei -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> GLsizei -> m ()
glUniform1i GLsizei
loc (GLsizei -> IO ()) -> GLsizei -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
bool then GLsizei
1 else GLsizei
0
    GLenum -> GLsizei -> Bool -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc Bool
bool

instance UniformValue Int where
  updateUniform :: forall (m :: * -> *). MonadIO m => GLenum -> GLsizei -> Int -> m ()
updateUniform GLenum
p GLsizei
loc Int
enum = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    GLsizei -> GLsizei -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> GLsizei -> m ()
glUniform1i GLsizei
loc (GLsizei -> IO ()) -> GLsizei -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLsizei) -> Int -> GLsizei
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> Int
fromEnum Int
enum
    GLenum -> GLsizei -> Int -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc Int
enum

instance UniformValue Float where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> Float -> m ()
updateUniform GLenum
p GLsizei
loc Float
float = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    GLsizei -> Float -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Float -> m ()
glUniform1f GLsizei
loc (Float -> IO ()) -> Float -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
float
    GLenum -> GLsizei -> Float -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc Float
float

instance UniformValue Double where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> Double -> m ()
updateUniform GLenum
p GLsizei
loc Double
d = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    GLsizei -> Float -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Float -> m ()
glUniform1f GLsizei
loc (Float -> IO ()) -> Float -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d
    GLenum -> GLsizei -> Double -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc Double
d

instance UniformValue (V2 Float) where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> V2 Float -> m ()
updateUniform GLenum
p GLsizei
loc V2 Float
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let V2 Float
x Float
y = (Float -> Float) -> V2 Float -> V2 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac V2 Float
v
    GLsizei -> Float -> Float -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLsizei -> Float -> Float -> m ()
glUniform2f GLsizei
loc Float
x Float
y
    GLenum -> GLsizei -> V2 Float -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc V2 Float
v

instance UniformValue (V3 Float) where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> V3 Float -> m ()
updateUniform GLenum
p GLsizei
loc V3 Float
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let V3 Float
x Float
y Float
z = (Float -> Float) -> V3 Float -> V3 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac V3 Float
v
    GLsizei -> Float -> Float -> Float -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLsizei -> Float -> Float -> Float -> m ()
glUniform3f GLsizei
loc Float
x Float
y Float
z
    GLenum -> GLsizei -> V3 Float -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc V3 Float
v

instance UniformValue (V4 Float) where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> V4 Float -> m ()
updateUniform GLenum
p GLsizei
loc V4 Float
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let (V4 Float
r Float
g Float
b Float
a) = Float -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Float -> Float) -> V4 Float -> V4 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V4 Float
v
    GLsizei -> Float -> Float -> Float -> Float -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLsizei -> Float -> Float -> Float -> Float -> m ()
glUniform4f GLsizei
loc Float
r Float
g Float
b Float
a
    GLenum -> GLsizei -> V4 Float -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc V4 Float
v

instance UniformValue (M44 Float) where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> M44 Float -> m ()
updateUniform GLenum
p GLsizei
loc M44 Float
val = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    M44 Float -> (Ptr (M44 Float) -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with M44 Float
val ((Ptr (M44 Float) -> IO ()) -> IO ())
-> (Ptr (M44 Float) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLsizei -> GLsizei -> GLboolean -> Ptr Float -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLsizei -> GLsizei -> GLboolean -> Ptr Float -> m ()
glUniformMatrix4fv GLsizei
loc GLsizei
1 GLboolean
forall {a}. (Eq a, Num a) => a
GL_TRUE (Ptr Float -> IO ())
-> (Ptr (M44 Float) -> Ptr Float) -> Ptr (M44 Float) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (M44 Float) -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr
    GLenum -> GLsizei -> M44 Float -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc M44 Float
val

instance UniformValue (V2 Int) where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> V2 Int -> m ()
updateUniform GLenum
p GLsizei
loc V2 Int
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let V2 GLsizei
x GLsizei
y = (Int -> GLsizei) -> V2 Int -> V2 GLsizei
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral V2 Int
v
    GLsizei -> GLsizei -> GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLsizei -> GLsizei -> GLsizei -> m ()
glUniform2i GLsizei
loc GLsizei
x GLsizei
y
    GLenum -> GLsizei -> V2 Int -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLenum -> GLsizei -> a -> m ()
clearUniformUpdateError GLenum
p GLsizei
loc V2 Int
v

instance UniformValue (Int,Int) where
  updateUniform :: forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> (Int, Int) -> m ()
updateUniform GLenum
p GLsizei
loc = GLenum -> GLsizei -> V2 Int -> m ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLenum -> GLsizei -> a -> m ()
updateUniform GLenum
p GLsizei
loc (V2 Int -> m ()) -> ((Int, Int) -> V2 Int) -> (Int, Int) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> V2 Int) -> (Int, Int) -> V2 Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2


--------------------------------------------------------------------------------
-- Matrix helpers
--------------------------------------------------------------------------------

-- | Constructs a matrix that shifts a vector horizontally or vertically.
mat4Translate :: Num a => V3 a -> M44 a
mat4Translate :: forall a. Num a => V3 a -> M44 a
mat4Translate = M33 a -> V3 a -> M44 a
forall a. Num a => M33 a -> V3 a -> M44 a
mkTransformationMat M33 a
forall a (t :: * -> *).
(Num a, Traversable t, Applicative t) =>
t (t a)
identity

-- | Constructs a matrix that rotates a vector.
mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a
mat4Rotate :: forall a. (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a
mat4Rotate a
phi V3 a
v = Quaternion a -> V3 a -> M44 a
forall a. Num a => Quaternion a -> V3 a -> M44 a
mkTransformation (V3 a -> a -> Quaternion a
forall a. (Epsilon a, Floating a) => V3 a -> a -> Quaternion a
axisAngle V3 a
v a
phi) (a -> a -> a -> V3 a
forall a. a -> a -> a -> V3 a
V3 a
0 a
0 a
0)

-- | Constructs a matrix that resizes a vector.
mat4Scale :: Num a => V3 a -> M44 a
mat4Scale :: forall a. Num a => V3 a -> M44 a
mat4Scale (V3 a
x a
y a
z) =
    V4 a -> V4 a -> V4 a -> V4 a -> V4 (V4 a)
forall a. a -> a -> a -> a -> V4 a
V4 (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
x a
0 a
0 a
0)
       (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
0 a
y a
0 a
0)
       (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
0 a
0 a
z a
0)
       (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
0 a
0 a
0 a
1)

mat4SkewXbyY :: Num a => a -> M44 a
mat4SkewXbyY :: forall a. Num a => a -> M44 a
mat4SkewXbyY a
a =
    V4 a -> V4 a -> V4 a -> V4 a -> V4 (V4 a)
forall a. a -> a -> a -> a -> V4 a
V4 (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
1 a
a a
0 a
0)
       (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
0 a
1 a
0 a
0)
       (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
0 a
0 a
1 a
0)
       (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
0 a
0 a
0 a
1)

-- | Constructs a matrix that converts screen coordinates to range 1,-1; with perspective.
orthoProjection
  :: Integral a
  => V2 a
  -- ^ The window width and height
  -> M44 Float
orthoProjection :: forall a. Integral a => V2 a -> M44 Float
orthoProjection (V2 a
ww a
wh) =
  let (Float
hw,Float
hh) = (a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
ww, a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
wh)
  in Float -> Float -> Float -> Float -> Float -> Float -> M44 Float
forall a. Fractional a => a -> a -> a -> a -> a -> a -> M44 a
ortho Float
0 Float
hw Float
hh Float
0 Float
0 Float
1

-- | Computes the boundingbox for an array of points.
boundingBox :: (Unbox a, Real a, Fractional a) => UV.Vector (V2 a) -> (V2 a, V2 a)
boundingBox :: forall a.
(Unbox a, Real a, Fractional a) =>
Vector (V2 a) -> (V2 a, V2 a)
boundingBox Vector (V2 a)
vs
  | Vector (V2 a) -> Bool
forall a. Unbox a => Vector a -> Bool
UV.null Vector (V2 a)
vs = (V2 a
0,V2 a
0)
  | Bool
otherwise = ((V2 a, V2 a) -> V2 a -> (V2 a, V2 a))
-> (V2 a, V2 a) -> Vector (V2 a) -> (V2 a, V2 a)
forall b a. Unbox b => (a -> b -> a) -> a -> Vector b -> a
UV.foldl' (V2 a, V2 a) -> V2 a -> (V2 a, V2 a)
forall {f :: * -> *} {a} {b} {b}.
(Applicative f, Real a, Fractional b, Fractional b, Ord b,
 Ord b) =>
(f b, f b) -> f a -> (f b, f b)
f (V2 a
br,V2 a
tl) Vector (V2 a)
vs
  where mn :: c -> a -> c
mn c
a = c -> c -> c
forall a. Ord a => a -> a -> a
min c
a (c -> c) -> (a -> c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c
forall a b. (Real a, Fractional b) => a -> b
realToFrac
        mx :: c -> a -> c
mx c
a = c -> c -> c
forall a. Ord a => a -> a -> a
max c
a (c -> c) -> (a -> c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c
forall a b. (Real a, Fractional b) => a -> b
realToFrac
        f :: (f b, f b) -> f a -> (f b, f b)
f (f b
a, f b
b) f a
c = (b -> a -> b
forall {a} {c}. (Real a, Fractional c, Ord c) => c -> a -> c
mn (b -> a -> b) -> f b -> f (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
a f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
c, b -> a -> b
forall {a} {c}. (Real a, Fractional c, Ord c) => c -> a -> c
mx (b -> a -> b) -> f b -> f (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
b f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
c)
        inf :: a
inf = a
1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
0
        ninf :: a
ninf = (-a
1)a -> a -> a
forall a. Fractional a => a -> a -> a
/a
0
        tl :: V2 a
tl = a -> a -> V2 a
forall a. a -> a -> V2 a
V2 a
ninf a
ninf
        br :: V2 a
br = a -> a -> V2 a
forall a. a -> a -> V2 a
V2 a
inf a
inf