summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL')
-rw-r--r--src/LambdaCube/GL/Backend.hs8
-rw-r--r--src/LambdaCube/GL/Input.hs388
-rw-r--r--src/LambdaCube/GL/Input/Type.hs527
-rw-r--r--src/LambdaCube/GL/Type.hs90
-rw-r--r--src/LambdaCube/GL/Util.hs205
5 files changed, 891 insertions, 327 deletions
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index c5e3190..08f10d4 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -30,6 +30,7 @@ import LambdaCube.Linear
30import LambdaCube.IR hiding (streamType) 30import LambdaCube.IR hiding (streamType)
31import qualified LambdaCube.IR as IR 31import qualified LambdaCube.IR as IR
32 32
33import LambdaCube.GL.Input.Type
33import LambdaCube.GL.Type 34import LambdaCube.GL.Type
34import LambdaCube.GL.Util 35import LambdaCube.GL.Util
35 36
@@ -487,7 +488,9 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
487 , let u = topUni n 488 , let u = topUni n
488 , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap 489 , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
489 ] 490 ]
490 uniInputType (GLUniform ty _) = ty 491 uniInputType (GLTypedUniform ty _) = unwitnessType ty
492 uniInputType (GLUniform ty _) = ty
493
491 494
492 -- object attribute stream commands 495 -- object attribute stream commands
493 streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs] 496 streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]
@@ -764,7 +767,8 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_
764 setup glIndexBufferRef buf $ glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf 767 setup glIndexBufferRef buf $ glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf
765 glDrawElements mode count typ indicesPtr 768 glDrawElements mode count typ indicesPtr
766 modifyIORef glDrawCallCounterRef succ 769 modifyIORef glDrawCallCounterRef succ
767 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref 770 GLSetUniform idx (GLTypedUniform ty ref) -> setUniform idx ty (readIORef ref)
771 GLSetUniform idx (GLUniform ty ref) -> return () -- putStrLn $ "TODO: setUniform FTexture2D"
768 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do 772 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
769 txObjVal <- readIORef ref 773 txObjVal <- readIORef ref
770 -- HINT: ugly and hacky 774 -- HINT: ugly and hacky
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index 5d2a49e..bd46fe0 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -1,9 +1,16 @@
1{-# LANGUAGE BangPatterns, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} 1{-# LANGUAGE BangPatterns, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE StandaloneDeriving #-}
2module LambdaCube.GL.Input where 8module LambdaCube.GL.Input where
3 9
4import Control.Applicative 10import Control.Applicative
5import Control.Exception 11import Control.Exception
6import Control.Monad 12import Control.Monad
13import Control.Monad.Reader
7import Control.Monad.Writer 14import Control.Monad.Writer
8import Data.Maybe 15import Data.Maybe
9import Data.IORef 16import Data.IORef
@@ -12,7 +19,9 @@ import Data.IntMap (IntMap)
12import Data.Vector (Vector,(//),(!)) 19import Data.Vector (Vector,(//),(!))
13import Data.Word 20import Data.Word
14import Data.String 21import Data.String
22import Data.Typeable
15import Foreign 23import Foreign
24import qualified Data.Dependent.Map as DMap
16import qualified Data.IntMap as IM 25import qualified Data.IntMap as IM
17import qualified Data.Set as S 26import qualified Data.Set as S
18import qualified Data.Map as Map 27import qualified Data.Map as Map
@@ -23,11 +32,12 @@ import qualified Data.ByteString.Char8 as SB
23 32
24import Graphics.GL.Core33 33import Graphics.GL.Core33
25 34
35import LambdaCube.GL.Input.Type
36import LambdaCube.GL.Type as T
37import LambdaCube.GL.Util
26import LambdaCube.IR as IR 38import LambdaCube.IR as IR
27import LambdaCube.Linear as IR 39import LambdaCube.Linear as IR
28import LambdaCube.PipelineSchema 40import LambdaCube.PipelineSchema
29import LambdaCube.GL.Type as T
30import LambdaCube.GL.Util
31 41
32import qualified LambdaCube.IR as IR 42import qualified LambdaCube.IR as IR
33 43
@@ -43,19 +53,19 @@ schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.emp
43 Just v -> v 53 Just v -> v
44 Nothing -> error "internal error (schemaFromPipeline)" 54 Nothing -> error "internal error (schemaFromPipeline)"
45 55
46mkUniform :: [(String,InputType)] -> IO (Map GLUniformName InputSetter, Map String GLUniform) 56mkUniform :: [(String,InputType)] -> IO (Map String GLUniform)
47mkUniform l = do 57mkUniform l = do
48 unisAndSetters <- forM l $ \(n,t) -> do 58 unis <- forM l $ \(n,t) -> do
49 (uni, setter) <- mkUniformSetter t 59 uni <- initializeUniform t
50 return ((n,uni),(fromString n,setter)) 60 return (n,uni)
51 let (unis,setters) = unzip unisAndSetters 61 return (Map.fromList unis)
52 return (Map.fromList setters, Map.fromList unis) 62
53 63
54allocStorage :: PipelineSchema -> IO GLStorage 64allocStorage :: PipelineSchema -> IO GLStorage
55allocStorage sch = do 65allocStorage sch = do
56 let sm = Map.fromList $ zip (Map.keys $ objectArrays sch) [0..] 66 let sm = Map.fromList $ zip (Map.keys $ objectArrays sch) [0..]
57 len = Map.size sm 67 len = Map.size sm
58 (setters,unis) <- mkUniform $ Map.toList $ uniforms sch 68 unis <- mkUniform $ Map.toList $ uniforms sch
59 seed <- newIORef 0 69 seed <- newIORef 0
60 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered) 70 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered)
61 size <- newIORef (0,0) 71 size <- newIORef (0,0)
@@ -65,7 +75,6 @@ allocStorage sch = do
65 , slotMap = sm 75 , slotMap = sm
66 , slotVector = slotV 76 , slotVector = slotV
67 , objSeed = seed 77 , objSeed = seed
68 , uniformSetter = setters
69 , uniformSetup = unis 78 , uniformSetup = unis
70 , screenSize = size 79 , screenSize = size
71 , pipelines = ppls 80 , pipelines = ppls
@@ -102,14 +111,15 @@ addObject input slotName prim indices attribs uniformNames = do
102 enabled <- newIORef True 111 enabled <- newIORef True
103 index <- readIORef seed 112 index <- readIORef seed
104 modifyIORef seed (1+) 113 modifyIORef seed (1+)
105 (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let t = fromMaybe (error $ "missing uniform: " ++ n) $ Map.lookup n (uniforms sch)] 114 unis <- mkUniform [(n,t) | n <- uniformNames,
115 let t = fromMaybe (error $ "missing uniform: " ++ n)
116 $ Map.lookup n (uniforms sch)]
106 cmdsRef <- newIORef (V.singleton V.empty) 117 cmdsRef <- newIORef (V.singleton V.empty)
107 let obj = Object 118 let obj = Object
108 { objSlot = slotIdx 119 { objSlot = slotIdx
109 , objPrimitive = prim 120 , objPrimitive = prim
110 , objIndices = indices 121 , objIndices = indices
111 , objAttributes = attribs 122 , objAttributes = attribs
112 , objUniSetter = setters
113 , objUniSetup = unis 123 , objUniSetup = unis
114 , objOrder = order 124 , objOrder = order
115 , objEnabled = enabled 125 , objEnabled = enabled
@@ -154,8 +164,11 @@ setObjectOrder p obj i = do
154 writeIORef (objOrder obj) i 164 writeIORef (objOrder obj) i
155 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder 165 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
156 166
167uniformSetter :: GLStorage -> Map String InputSetter
168uniformSetter = uniformSetup
169
157objectUniformSetter :: Object -> Map GLUniformName InputSetter 170objectUniformSetter :: Object -> Map GLUniformName InputSetter
158objectUniformSetter = objUniSetter 171objectUniformSetter = objUniSetup
159 172
160setScreenSize :: GLStorage -> Word -> Word -> IO () 173setScreenSize :: GLStorage -> Word -> Word -> IO ()
161setScreenSize p w h = writeIORef (screenSize p) (w,h) 174setScreenSize p w h = writeIORef (screenSize p) (w,h)
@@ -212,7 +225,8 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
212 , let u = Map.findWithDefault (topUni n) n objUnis 225 , let u = Map.findWithDefault (topUni n) n objUnis
213 , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap 226 , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
214 ] 227 ]
215 uniInputType (GLUniform ty _) = ty 228 uniInputType (GLTypedUniform ty _) = unwitnessType ty
229 uniInputType (GLUniform ty _) = ty
216 230
217 -- object attribute stream commands 231 -- object attribute stream commands
218 objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs] 232 objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs]
@@ -252,187 +266,177 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
252 -- constant generic attribute 266 -- constant generic attribute
253 constAttr -> GLSetVertexAttrib i constAttr 267 constAttr -> GLSetVertexAttrib i constAttr
254 268
255nullSetter :: GLUniformName -> String -> a -> IO () 269newtype UniM a = UniM (ReaderT (Map GLUniformName GLUniform) (Writer [IO ()]) a)
256nullSetter n t _ = return () 270deriving instance Functor UniM
257--nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show n ++ " :: " ++ t 271deriving instance Applicative UniM
258 272deriving instance Monad UniM
259uniformBool :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Bool 273deriving instance MonadReader (Map String GLUniform) UniM
260uniformV2B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2B 274deriving instance MonadWriter [IO ()] UniM
261uniformV3B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3B 275
262uniformV4B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4B 276
263 277(@=) :: (Typeable a, Uniformable a) => String -> IO a -> UniM ()
264uniformWord :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Word32 278name @= val = do
265uniformV2U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2U 279 u <- do
266uniformV3U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3U 280 us <- ask
267uniformV4U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4U 281 return $ us Map.! name
268 282 case u of
269uniformInt :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Int32 283
270uniformV2I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2I 284 GLTypedUniform ty ref -> do
271uniformV3I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3I 285 case DMap.lookup ty (uniformContexts val) of
272uniformV4I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4I 286 Just UniformContext -> do
273 287 tell [val >>= writeIORef ref . GLUniformValue]
274uniformFloat :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Float 288 Nothing -> do
275uniformV2F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2F 289 tell [throwIO $ typeMismatch ty ref]
276uniformV3F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3F 290
277uniformV4F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4F 291 GLUniform FTexture2D ref -> case withTypes val ref <$> eqT of
278 292 Just Refl -> tell [val >>= writeIORef ref]
279uniformM22F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M22F 293 Nothing -> tell [ Prelude.putStrLn $ "WARNING: Texture2D variable "
280uniformM23F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M23F 294 ++ show name
281uniformM24F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M24F 295 ++ " cannot recieve value " ++ show (typeRep val)
282uniformM32F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M32F 296 , throwIO $ typeMismatch ref val
283uniformM33F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M33F 297 ]
284uniformM34F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M34F 298
285uniformM42F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M42F 299 GLUniform ty _ -> tell [Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show name ++ " :: " ++ show ty]
286uniformM43F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M43F
287uniformM44F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M44F
288
289uniformFTexture2D :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun TextureData
290
291uniformBool n is = case Map.lookup n is of
292 Just (SBool fun) -> fun
293 _ -> nullSetter n "Bool"
294
295uniformV2B n is = case Map.lookup n is of
296 Just (SV2B fun) -> fun
297 _ -> nullSetter n "V2B"
298
299uniformV3B n is = case Map.lookup n is of
300 Just (SV3B fun) -> fun
301 _ -> nullSetter n "V3B"
302 300
303uniformV4B n is = case Map.lookup n is of
304 Just (SV4B fun) -> fun
305 _ -> nullSetter n "V4B"
306
307uniformWord n is = case Map.lookup n is of
308 Just (SWord fun) -> fun
309 _ -> nullSetter n "Word"
310
311uniformV2U n is = case Map.lookup n is of
312 Just (SV2U fun) -> fun
313 _ -> nullSetter n "V2U"
314
315uniformV3U n is = case Map.lookup n is of
316 Just (SV3U fun) -> fun
317 _ -> nullSetter n "V3U"
318
319uniformV4U n is = case Map.lookup n is of
320 Just (SV4U fun) -> fun
321 _ -> nullSetter n "V4U"
322
323uniformInt n is = case Map.lookup n is of
324 Just (SInt fun) -> fun
325 _ -> nullSetter n "Int"
326
327uniformV2I n is = case Map.lookup n is of
328 Just (SV2I fun) -> fun
329 _ -> nullSetter n "V2I"
330
331uniformV3I n is = case Map.lookup n is of
332 Just (SV3I fun) -> fun
333 _ -> nullSetter n "V3I"
334
335uniformV4I n is = case Map.lookup n is of
336 Just (SV4I fun) -> fun
337 _ -> nullSetter n "V4I"
338
339uniformFloat n is = case Map.lookup n is of
340 Just (SFloat fun) -> fun
341 _ -> nullSetter n "Float"
342
343uniformV2F n is = case Map.lookup n is of
344 Just (SV2F fun) -> fun
345 _ -> nullSetter n "V2F"
346
347uniformV3F n is = case Map.lookup n is of
348 Just (SV3F fun) -> fun
349 _ -> nullSetter n "V3F"
350
351uniformV4F n is = case Map.lookup n is of
352 Just (SV4F fun) -> fun
353 _ -> nullSetter n "V4F"
354
355uniformM22F n is = case Map.lookup n is of
356 Just (SM22F fun) -> fun
357 _ -> nullSetter n "M22F"
358
359uniformM23F n is = case Map.lookup n is of
360 Just (SM23F fun) -> fun
361 _ -> nullSetter n "M23F"
362
363uniformM24F n is = case Map.lookup n is of
364 Just (SM24F fun) -> fun
365 _ -> nullSetter n "M24F"
366
367uniformM32F n is = case Map.lookup n is of
368 Just (SM32F fun) -> fun
369 _ -> nullSetter n "M32F"
370
371uniformM33F n is = case Map.lookup n is of
372 Just (SM33F fun) -> fun
373 _ -> nullSetter n "M33F"
374
375uniformM34F n is = case Map.lookup n is of
376 Just (SM34F fun) -> fun
377 _ -> nullSetter n "M34F"
378
379uniformM42F n is = case Map.lookup n is of
380 Just (SM42F fun) -> fun
381 _ -> nullSetter n "M42F"
382
383uniformM43F n is = case Map.lookup n is of
384 Just (SM43F fun) -> fun
385 _ -> nullSetter n "M43F"
386
387uniformM44F n is = case Map.lookup n is of
388 Just (SM44F fun) -> fun
389 _ -> nullSetter n "M44F"
390
391uniformFTexture2D n is = case Map.lookup n is of
392 Just (SFTexture2D fun) -> fun
393 _ -> nullSetter n "FTexture2D"
394
395type UniM = Writer [Map GLUniformName InputSetter -> IO ()]
396
397class UniformSetter a where
398 (@=) :: GLUniformName -> IO a -> UniM ()
399
400setUniM :: (n -> Map GLUniformName InputSetter -> a -> IO ()) -> n -> IO a -> UniM ()
401setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act]
402
403instance UniformSetter Bool where (@=) = setUniM uniformBool
404instance UniformSetter V2B where (@=) = setUniM uniformV2B
405instance UniformSetter V3B where (@=) = setUniM uniformV3B
406instance UniformSetter V4B where (@=) = setUniM uniformV4B
407instance UniformSetter Word32 where (@=) = setUniM uniformWord
408instance UniformSetter V2U where (@=) = setUniM uniformV2U
409instance UniformSetter V3U where (@=) = setUniM uniformV3U
410instance UniformSetter V4U where (@=) = setUniM uniformV4U
411instance UniformSetter Int32 where (@=) = setUniM uniformInt
412instance UniformSetter V2I where (@=) = setUniM uniformV2I
413instance UniformSetter V3I where (@=) = setUniM uniformV3I
414instance UniformSetter V4I where (@=) = setUniM uniformV4I
415instance UniformSetter Float where (@=) = setUniM uniformFloat
416instance UniformSetter V2F where (@=) = setUniM uniformV2F
417instance UniformSetter V3F where (@=) = setUniM uniformV3F
418instance UniformSetter V4F where (@=) = setUniM uniformV4F
419instance UniformSetter M22F where (@=) = setUniM uniformM22F
420instance UniformSetter M23F where (@=) = setUniM uniformM23F
421instance UniformSetter M24F where (@=) = setUniM uniformM24F
422instance UniformSetter M32F where (@=) = setUniM uniformM32F
423instance UniformSetter M33F where (@=) = setUniM uniformM33F
424instance UniformSetter M34F where (@=) = setUniM uniformM34F
425instance UniformSetter M42F where (@=) = setUniM uniformM42F
426instance UniformSetter M43F where (@=) = setUniM uniformM43F
427instance UniformSetter M44F where (@=) = setUniM uniformM44F
428instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D
429 301
430updateUniforms :: GLStorage -> UniM a -> IO () 302updateUniforms :: GLStorage -> UniM a -> IO ()
431updateUniforms storage m = sequence_ l where 303updateUniforms storage (UniM m) = sequence_ l where
432 setters = uniformSetter storage 304 setters = uniformSetup storage
433 l = map ($ setters) $ execWriter m 305 l = execWriter $ runReaderT m setters
434 306
435updateObjectUniforms :: Object -> UniM a -> IO () 307updateObjectUniforms :: Object -> UniM a -> IO ()
436updateObjectUniforms object m = sequence_ l where 308updateObjectUniforms object (UniM m) = sequence_ l where
437 setters = objectUniformSetter object 309 setters = objectUniformSetter object
438 l = map ($ setters) $ execWriter m 310 l = execWriter $ runReaderT m setters
311
312-- | Set a uniform ref.
313setGLUniform :: Typeable a =>
314 (forall v. Typeable v => TypeTag v -> Maybe (UniformContext a v))
315 -> String -- ^ For warning messages, name of uniform.
316 -> GLUniform -- ^ Uniform ref to set.
317 -> a -- ^ Value to store.
318 -> IO ()
319setGLUniform resolv name u val = case u of
320 GLTypedUniform ty ref -> do
321 case resolv ty of
322 Just UniformContext -> writeIORef ref $ GLUniformValue val
323 Nothing -> warn $ unwords [ "Cannot set", show $ unwitnessType ty
324 , "uniform", name
325 , "to", show (typeOf val)
326 , "value." ]
327
328 GLUniform textureType ref -> case withTypes (Just val) ref <$> eqT of
329 Just Refl -> writeIORef ref val
330 Nothing -> warn $ unwords [ show textureType
331 , "uniform", name
332 , "only accepts values of type TextureData." ]
333 where warn s = putStrLn $ "WARNING: " ++ s
334
335-- | Lookup and set a Uniform ref.
336setUniformRef :: ( Typeable a
337 , Show name, Ord name
338 ) => (forall v. Typeable v => TypeTag v -> Maybe (UniformContext a v))
339 -> name
340 -> Map name GLUniform
341 -> a
342 -> IO ()
343setUniformRef resolv name us val = case Map.lookup name us of
344 Nothing -> warn $ "unknown uniform: " ++ show name
345 Just u -> setGLUniform resolv (show name) u val
346 where warn s = putStrLn $ "WARNING: " ++ s
347
348uniformOf :: (Show name, Ord name, GLData a have) =>
349 TypeTag have
350 -> name
351 -> Map name GLUniform
352 -> a
353 -> IO ()
354uniformOf have = setUniformRef $ knownContext have
355
356uniform :: (Typeable a, Show name, Ord name, Uniformable a) =>
357 name -> Map name GLUniform -> a -> IO ()
358uniform n o a = setUniformRef (resolveContext a) n o a
359
360
361uniformFTexture2D :: SB.ByteString -> Map GLUniformName GLUniform -> TextureData -> IO ()
362uniformFTexture2D =
363 -- TODO: Check that the uniform is of the expected FTexture2D type.
364 uniform . SB.unpack
365
366uniformBool :: (Show name, Ord name) => name -> Map name GLUniform -> Bool -> IO ()
367uniformV2B :: (Show name, Ord name, GLData a (GLVector 2 Word32)) => name -> Map name GLUniform -> a -> IO ()
368uniformV3B :: (Show name, Ord name, GLData a (GLVector 3 Word32)) => name -> Map name GLUniform -> a -> IO ()
369uniformV4B :: (Show name, Ord name, GLData a (GLVector 4 Word32)) => name -> Map name GLUniform -> a -> IO ()
370uniformBool = uniformOf TypeBool
371uniformV2B = uniformOf TypeV2B
372uniformV3B = uniformOf TypeV3B
373uniformV4B = uniformOf TypeV4B
374
375uniformWord :: (Show name, Ord name) => name -> Map name GLUniform -> Word32 -> IO ()
376uniformV2U :: (Typeable f, GLData (f Word32) (GLVector 2 Word32)) =>
377 String -> Map GLUniformName GLUniform -> f Word32 -> IO ()
378uniformV3U :: (Typeable f, GLData (f Word32) (GLVector 3 Word32)) =>
379 String -> Map GLUniformName GLUniform -> f Word32 -> IO ()
380uniformV4U :: (Typeable f, GLData (f Word32) (GLVector 4 Word32)) =>
381 String -> Map GLUniformName GLUniform -> f Word32 -> IO ()
382uniformWord = uniformOf TypeWord
383uniformV2U = uniformOf TypeV2U
384uniformV3U = uniformOf TypeV3U
385uniformV4U = uniformOf TypeV4U
386
387uniformFloat :: (Show name, Ord name) => name -> Map name GLUniform -> Float -> IO ()
388uniformV2F :: (Typeable f, GLData (f Float) (GLVector 2 Float)) =>
389 String -> Map GLUniformName GLUniform -> f Float -> IO ()
390uniformV3F :: (Typeable f, GLData (f Float) (GLVector 3 Float)) =>
391 String -> Map GLUniformName GLUniform -> f Float -> IO ()
392uniformV4F :: (Typeable f, GLData (f Float) (GLVector 4 Float)) =>
393 String -> Map GLUniformName GLUniform -> f Float -> IO ()
394uniformFloat = uniformOf TypeFloat
395uniformV2F = setUniformRef (knownContext TypeV2F)
396uniformV3F = setUniformRef (knownContext TypeV3F)
397uniformV4F = setUniformRef (knownContext TypeV4F)
398
399uniformInt :: (Show name, Ord name) => name -> Map name GLUniform -> Int32 -> IO ()
400uniformV2I :: (Typeable f, GLData (f Int32) (GLVector 2 Int32)) =>
401 String -> Map GLUniformName GLUniform -> f Int32 -> IO ()
402uniformV3I :: (Typeable f, GLData (f Int32) (GLVector 3 Int32)) =>
403 String -> Map GLUniformName GLUniform -> f Int32 -> IO ()
404uniformV4I :: (Typeable f, GLData (f Int32) (GLVector 4 Int32)) =>
405 String -> Map GLUniformName GLUniform -> f Int32 -> IO ()
406uniformInt = uniformOf TypeInt
407uniformV2I = uniformOf TypeV2I
408uniformV3I = uniformOf TypeV3I
409uniformV4I = uniformOf TypeV4I
410
411{-
412Note: This works to infer the type Float for literals without fixing the matrix type:
413
414 type family MatrixComponent m where
415 MatrixComponent (f (g c)) = c
416 MatrixComponent (f c) = c
417
418 uniformM44F :: ( MatrixComponent a ~ Float , GLData a (GLMatrix 4 4 Float))
419 => String -> Map String GLUniform -> a -> IO ()
420
421However, it breaks the ability to partially apply without a type signature.
422Therefore, I'm forcing LambdaCube's internal matrix types for uniformM*
423functions.
424-}
425uniformM22F :: (Show name, Ord name) => name -> Map name GLUniform -> M22F -> IO ()
426uniformM23F :: (Show name, Ord name) => name -> Map name GLUniform -> M23F -> IO ()
427uniformM24F :: (Show name, Ord name) => name -> Map name GLUniform -> M24F -> IO ()
428uniformM32F :: (Show name, Ord name) => name -> Map name GLUniform -> M32F -> IO ()
429uniformM33F :: (Show name, Ord name) => name -> Map name GLUniform -> M33F -> IO ()
430uniformM34F :: (Show name, Ord name) => name -> Map name GLUniform -> M34F -> IO ()
431uniformM42F :: (Show name, Ord name) => name -> Map name GLUniform -> M42F -> IO ()
432uniformM43F :: (Show name, Ord name) => name -> Map name GLUniform -> M43F -> IO ()
433uniformM44F :: (Show name, Ord name) => name -> Map name GLUniform -> M44F -> IO ()
434uniformM22F = uniformOf TypeM22F
435uniformM23F = uniformOf TypeM23F
436uniformM24F = uniformOf TypeM24F
437uniformM32F = uniformOf TypeM32F
438uniformM33F = uniformOf TypeM33F
439uniformM34F = uniformOf TypeM34F
440uniformM42F = uniformOf TypeM42F
441uniformM43F = uniformOf TypeM43F
442uniformM44F = uniformOf TypeM44F
diff --git a/src/LambdaCube/GL/Input/Type.hs b/src/LambdaCube/GL/Input/Type.hs
new file mode 100644
index 0000000..eaadce5
--- /dev/null
+++ b/src/LambdaCube/GL/Input/Type.hs
@@ -0,0 +1,527 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE StandaloneDeriving #-}
11
12-- | Module : LambdaCube.GL.Input.Type
13--
14-- This module provides types for describing the matrix and vector ABI for
15-- passing vectors and matrices to OpenGL shaders as "uniforms".
16--
17-- For a given shader input 'InputType', there is associated (via
18-- 'witnessType') a type-level description of the GL calls necessary to upload
19-- pointers to the GPU.
20--
21-- To make it so that a Haskell value can be uploaded, instances of 'GLData'
22-- and 'Uniformable' should be provided. These describe how to marshall a
23-- haskell type into a suitable pointer for a given context.
24--
25-- For example, users of the hmatrix package, might find these instances useful:
26--
27-- > import GHC.TypeLits
28-- > import LambdaCube.GL.Input.Type
29-- > import Numeric.LinearAlgebra
30-- > import Numeric.LinearAlgebra.Devel
31-- >
32-- > instance Uniformable (Matrix Float) where
33-- > uniformContexts _ = contexts floatMatrices
34-- >
35-- > instance Uniformable (Vector Float) where
36-- > uniformContexts _ = contexts $ do
37-- > supports TypeFloat
38-- > supports TypeV2F
39-- > supports TypeV3F
40-- > supports TypeV4F
41-- >
42-- > instance (KnownNat r, KnownNat c) => GLData (Matrix Float) (GLMatrix r c Float) where
43-- > marshalUniform abi mat = case matrixDimensions abi of
44-- > (r,c) | fromIntegral (natVal r) /= rows mat -> Nothing
45-- > | fromIntegral (natVal c) /= cols mat -> Nothing
46-- > _ -> let isRowOrder = case orderOf mat of
47-- > RowMajor -> 1
48-- > ColumnMajor -> 0
49-- > in Just $ MarshalGLMatrix
50-- > $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr)
51-- >
52-- > instance KnownNat n => GLData (Vector Float) (GLVector n Float) where
53-- > marshalUniform abi vec
54-- > | natVal (vectorLength abi) /= fromIntegral (size vec) = Nothing
55-- > | otherwise = Just $ MarshalGLVector
56-- > $ \f -> apply vec (\ptr -> f 1 ptr) (\n ptr -> ptr)
57module LambdaCube.GL.Input.Type where
58
59import Control.Monad
60import Control.Monad.State
61import Data.Functor.Identity
62import Data.Typeable
63import Foreign
64import GHC.TypeLits
65
66import Data.Dependent.Map as DMap
67import Data.Dependent.Sum
68import Data.GADT.Compare
69
70import Graphics.GL.Core33
71import LambdaCube.IR (InputType(..))
72
73
74-- | A 'Uniformable' type /a/ has a runtime dictionary of available instances
75-- of 'GLData' /a/ /c/. For example, if you have a matrix type that does
76-- not include type-level dimension information, you may want to set
77--
78-- > uniformContexts _ = contexts floatMatrices
79--
80-- Use 'contexts' and 'supports' to list individual instances. Typically, for
81-- dimension-specific types, 'uniformContexts' will be a singleton map.
82--
83-- Note that if a context is known at compile-time, then the compiler can
84-- lookup an appropriate instance. This class is provided so that the lookup
85-- can happen at runtime instead.
86class Uniformable a where
87 uniformContexts :: proxy a -> DMap TypeTag (UniformContext a)
88
89-- | A light wrapper over 'execState' to make it easier to specify the
90-- 'uniformContexts' DMap.
91contexts :: State (DMap TypeTag (UniformContext a)) () -> DMap TypeTag (UniformContext a)
92contexts = flip execState DMap.empty
93
94-- | Inserts an instance into the 'uniformContexts' DMap. See 'floatMatrices'
95-- for an example.
96supports :: GLData a c => TypeTag c -> State (DMap TypeTag (UniformContext a)) ()
97supports ty = modify' (DMap.insert ty UniformContext)
98
99
100-- | A set of GLData instances for all Float matrix types. It is defined:
101--
102-- > floatMatrices = do
103-- > supports TypeM22F
104-- > supports TypeM23F
105-- > supports TypeM24F
106-- > supports TypeM32F
107-- > supports TypeM33F
108-- > supports TypeM34F
109-- > supports TypeM42F
110-- > supports TypeM43F
111-- > supports TypeM44F
112--
113-- Use 'contexts' to turn this into a 'DMap' suitable to implemented 'uniformContexts'.
114floatMatrices :: (GLData a (GLMatrix 2 2 Float),
115 GLData a (GLMatrix 2 3 Float),
116 GLData a (GLMatrix 2 4 Float),
117 GLData a (GLMatrix 3 2 Float),
118 GLData a (GLMatrix 3 3 Float),
119 GLData a (GLMatrix 3 4 Float),
120 GLData a (GLMatrix 4 2 Float),
121 GLData a (GLMatrix 4 3 Float),
122 GLData a (GLMatrix 4 4 Float)) =>
123 State (DMap TypeTag (UniformContext a)) ()
124floatMatrices = do
125 supports TypeM22F
126 supports TypeM23F
127 supports TypeM24F
128 supports TypeM32F
129 supports TypeM33F
130 supports TypeM34F
131 supports TypeM42F
132 supports TypeM43F
133 supports TypeM44F
134
135-- | A runtime witness for an instance of 'GLData' /a/ /c/. To obtain a
136-- witness given a specific context 'TypeTag' /c/, perform a lookup into the
137-- 'uniformContexts' DMap.
138data UniformContext a c = GLData a c => UniformContext
139
140-- | Type-check (at runtime) a specific GLData instance.
141knownContext :: (GLData a have, Typeable have, Typeable want) => TypeTag have -> TypeTag want -> Maybe (UniformContext a want)
142knownContext known ty = do
143 Refl <- withTypes known ty <$> eqT
144 return UniformContext
145
146-- | Lookup a GLData instance, given a Uniformable value.
147resolveContext :: Uniformable a => a -> TypeTag want -> Maybe (UniformContext a want)
148resolveContext val ty = DMap.lookup ty . uniformContexts . mkproxy $ val
149 where
150 mkproxy :: val -> Proxy val
151 mkproxy _ = Proxy
152
153
154-- | This type classifies a shader "uniform" input based on the OpenGL calls
155-- necessary to upload it to the GPU. The primitive types are described as if
156-- they are 1-vectors. Vector types are described by 'GLVector' and matrix
157-- types are described by 'GLMatrix'.
158--
159-- Currently, Texture uniforms are not described and there is a, probably
160-- useless, run-time distinction between Bool and Word which have the same
161-- OpenGL ABI.
162--
163-- Use 'witnessType' to obtain this from a runtime-only value.
164data TypeTag t where
165 TypeBool :: TypeTag (GLVector 1 Word32)
166 TypeV2B :: TypeTag (GLVector 2 Word32)
167 TypeV3B :: TypeTag (GLVector 3 Word32)
168 TypeV4B :: TypeTag (GLVector 4 Word32)
169 TypeWord :: TypeTag (GLVector 1 Word32)
170 TypeV2U :: TypeTag (GLVector 2 Word32)
171 TypeV3U :: TypeTag (GLVector 3 Word32)
172 TypeV4U :: TypeTag (GLVector 4 Word32)
173
174 TypeInt :: TypeTag (GLVector 1 Int32)
175 TypeV2I :: TypeTag (GLVector 2 Int32)
176 TypeV3I :: TypeTag (GLVector 3 Int32)
177 TypeV4I :: TypeTag (GLVector 4 Int32)
178
179 TypeFloat :: TypeTag (GLVector 1 Float)
180 TypeV2F :: TypeTag (GLVector 2 Float)
181 TypeV3F :: TypeTag (GLVector 3 Float)
182 TypeV4F :: TypeTag (GLVector 4 Float)
183
184 TypeM22F :: TypeTag (GLMatrix 2 2 Float)
185 TypeM23F :: TypeTag (GLMatrix 3 2 Float)
186 TypeM24F :: TypeTag (GLMatrix 4 2 Float)
187 TypeM32F :: TypeTag (GLMatrix 2 3 Float)
188 TypeM33F :: TypeTag (GLMatrix 3 3 Float)
189 TypeM34F :: TypeTag (GLMatrix 4 3 Float)
190 TypeM42F :: TypeTag (GLMatrix 2 4 Float)
191 TypeM43F :: TypeTag (GLMatrix 3 4 Float)
192 TypeM44F :: TypeTag (GLMatrix 4 4 Float)
193
194instance GEq TypeTag where
195 geq a b = do
196 Refl <- geq (glABI a) (glABI b)
197 guard $ isBoolTag a == isBoolTag b
198 return Refl
199
200instance GCompare TypeTag where
201 gcompare a b = case compare (isBoolTag a) (isBoolTag b) of
202 LT -> GLT
203 EQ -> gcompare (glABI a) (glABI b)
204 GT -> GGT
205
206-- | This function provides the only term-only information in the 'TypeTag'
207-- type. Booleans are treated similarly to unsigned ints by OpenGL, so the
208-- distinction is not made in the type of the tag and the 'GEq' instance of
209-- 'TypeTag' must use this helper to help distinguish based on on the runtime
210-- information.
211isBoolTag :: TypeTag t -> Bool
212isBoolTag TypeBool = True
213isBoolTag TypeV2B = True
214isBoolTag TypeV3B = True
215isBoolTag TypeV4B = True
216isBoolTag _ = False
217
218
219-- | Obtain a type-level description of a uniform type context.
220--
221-- See 'unwitnessType' for the inverse operation.
222witnessType :: InputType -> Maybe (Some TypeTag)
223witnessType Bool = Just $ This TypeBool
224witnessType V2B = Just $ This TypeV2B
225witnessType V3B = Just $ This TypeV3B
226witnessType V4B = Just $ This TypeV4B
227witnessType Word = Just $ This TypeWord
228witnessType V2U = Just $ This TypeV2U
229witnessType V3U = Just $ This TypeV3U
230witnessType V4U = Just $ This TypeV4U
231witnessType Int = Just $ This TypeInt
232witnessType V2I = Just $ This TypeV2I
233witnessType V3I = Just $ This TypeV3I
234witnessType V4I = Just $ This TypeV4I
235witnessType Float = Just $ This TypeFloat
236witnessType V2F = Just $ This TypeV2F
237witnessType V3F = Just $ This TypeV3F
238witnessType V4F = Just $ This TypeV4F
239witnessType M22F = Just $ This TypeM22F
240witnessType M23F = Just $ This TypeM23F
241witnessType M24F = Just $ This TypeM24F
242witnessType M32F = Just $ This TypeM32F
243witnessType M33F = Just $ This TypeM33F
244witnessType M34F = Just $ This TypeM34F
245witnessType M42F = Just $ This TypeM42F
246witnessType M43F = Just $ This TypeM43F
247witnessType M44F = Just $ This TypeM44F
248witnessType _ = Nothing
249
250-- | Discard type-level input information. Inverse of 'witnessType'.
251unwitnessType :: TypeTag c -> InputType
252unwitnessType TypeBool = Bool
253unwitnessType TypeV2B = V2B
254unwitnessType TypeV3B = V3B
255unwitnessType TypeV4B = V4B
256unwitnessType TypeWord = Word
257unwitnessType TypeV2U = V2U
258unwitnessType TypeV3U = V3U
259unwitnessType TypeV4U = V4U
260unwitnessType TypeInt = Int
261unwitnessType TypeV2I = V2I
262unwitnessType TypeV3I = V3I
263unwitnessType TypeV4I = V4I
264unwitnessType TypeFloat = Float
265unwitnessType TypeV2F = V2F
266unwitnessType TypeV3F = V3F
267unwitnessType TypeV4F = V4F
268unwitnessType TypeM22F = M22F
269unwitnessType TypeM23F = M23F
270unwitnessType TypeM24F = M24F
271unwitnessType TypeM32F = M32F
272unwitnessType TypeM33F = M33F
273unwitnessType TypeM34F = M34F
274unwitnessType TypeM42F = M42F
275unwitnessType TypeM43F = M43F
276unwitnessType TypeM44F = M44F
277
278
279-- | A function used to upload a "uniform" primitive value or vector to the
280-- GPU. If /n/ is 1, then it uploads a primitive value of type /typ/.
281-- Otherwise, it uploads a vector of length /n/.
282--
283-- The arguments to the function are:
284--
285-- * An integer naming the uniform input slot.
286--
287-- * An element count which, if greater than 1, will bulk-upload an array of
288-- values.
289--
290-- * A pointer to the value or values to be uploaded.
291--
292-- Use 'glUniform' to obtain this for a given type context.
293data GLVector (n :: Nat) typ
294 = GLVector (Int32 -> GLsizei -> Ptr typ -> IO ())
295
296
297-- | A function used to upload a "uniform" /r/ × /c/ matrix of /typ/ to the
298-- GPU. The arguments are:
299--
300-- * An integer naming the uniform input slot.
301--
302-- * An element count which, if greater than 1, will bulk-upload an array.
303--
304-- * A flag that is GL_TRUE if the values at the pointer are arranged in
305-- row-major order. Set this to GL_FALSE to indicate column-major ordering.
306-- Row-major means that the first /c/ contiguous values at the pointer
307-- constitute the first row of the matrix.
308--
309-- * A pointer to the matrix values.
310--
311-- IMPORTANT: This type flouts the usual graphics convention of width×height,
312-- which is used in the naming of the constructors for 'InputType' and
313-- 'TypeTag', and instead instead follows the opposite, matrix-math convention,
314-- of rows×columns. Thus, @'TypeM42F'@ is associated with @(GLMatrix 2 4
315-- Float)@.
316--
317-- Use 'glUniform' to obtain this for a given type context.
318data GLMatrix (r :: Nat) (c :: Nat) typ
319 = GLMatrix (Int32 -> GLsizei -> GLboolean -> Ptr typ -> IO ())
320
321-- | Obtain a suitable 'GLVector' or 'GLMatrix' OpenGL API function for a given
322-- uniform type.
323glUniform :: TypeTag a -> a
324glUniform TypeBool = GLVector glUniform1uiv
325glUniform TypeWord = GLVector glUniform1uiv
326glUniform TypeInt = GLVector glUniform1iv
327glUniform TypeFloat = GLVector glUniform1fv
328glUniform TypeV2B = GLVector glUniform2uiv
329glUniform TypeV2U = GLVector glUniform2uiv
330glUniform TypeV2I = GLVector glUniform2iv
331glUniform TypeV2F = GLVector glUniform2fv
332glUniform TypeV3B = GLVector glUniform3uiv
333glUniform TypeV3U = GLVector glUniform3uiv
334glUniform TypeV3I = GLVector glUniform3iv
335glUniform TypeV3F = GLVector glUniform3fv
336glUniform TypeV4B = GLVector glUniform4uiv
337glUniform TypeV4U = GLVector glUniform4uiv
338glUniform TypeV4I = GLVector glUniform4iv
339glUniform TypeV4F = GLVector glUniform4fv
340glUniform TypeM22F = GLMatrix glUniformMatrix2fv
341glUniform TypeM23F = GLMatrix glUniformMatrix2x3fv
342glUniform TypeM24F = GLMatrix glUniformMatrix2x4fv
343glUniform TypeM32F = GLMatrix glUniformMatrix3x2fv
344glUniform TypeM33F = GLMatrix glUniformMatrix3fv
345glUniform TypeM34F = GLMatrix glUniformMatrix3x4fv
346glUniform TypeM42F = GLMatrix glUniformMatrix4x2fv
347glUniform TypeM43F = GLMatrix glUniformMatrix4x3fv
348glUniform TypeM44F = GLMatrix glUniformMatrix4fv
349
350-- | 'GLData' /a/ /c/ is true when /a/ can be used as GL shader "uniform"
351-- input for a 'GLVector' or 'GLMatrix' uniform context /c/.
352--
353-- For simple (non-matrix) types that implement 'Storable', a default
354-- implementation, implemented by 'marshalUniformStorable', is provided, so in
355-- this case, simply declare the instance. If a 'Storable' column-major matrix
356-- type, 'marshalColumnMajor' can be used.
357class (Typeable c, Typeable a) => GLData a c where
358 -- | Provide a pointer suitable for passing to the OpenGL api.
359 marshalUniform :: GLABI c -- ^ Description of the variable type of the GL uniform.
360 -> a -- ^ The value to upload to the GPU.
361 -> Maybe (MarshalGL c)
362
363 default marshalUniform :: ( c ~ GLVector n typ
364 , Storable a
365 ) => GLABI c -> a -> Maybe (MarshalGL c)
366 marshalUniform _ a = Just (marshalUniformStorable a)
367
368-- | A suitable default for 'Storable' uniform non-matrix types.
369marshalUniformStorable :: Storable a => a -> MarshalGL (GLVector n typ)
370marshalUniformStorable a = MarshalGLVector $ \f -> with a (f 1 . castPtr)
371
372-- | A suitable default for 'Storable' uniform column-major matrix types.
373-- Column-major means that columns are stored as contiguous regions of memory
374-- at the pointer.
375marshalColumnMajor :: Storable a => a -> MarshalGL (GLMatrix r c typ)
376marshalColumnMajor a = MarshalGLMatrix $ \f -> with a (f 1 GL_FALSE . castPtr)
377
378
379-- | Run-time information about a "uniform" type context. A proxy for the
380-- pointer type is provided directly. You can use 'vectorLength' or
381-- 'matrixDimensions' to extract proxies for size information.
382--
383-- You can obtain this from a 'TypeTag' using 'glABI'.
384data GLABI m where
385 IsGLVector :: KnownNat n => GLPointerType typ -> GLABI (GLVector n typ)
386 IsGLMatrix :: (KnownNat r, KnownNat c) => GLPointerType typ -> GLABI (GLMatrix r c typ)
387
388instance GEq GLABI where
389 geq a@(IsGLVector x) b@(IsGLVector y) = do
390 Refl <- geq x y
391 Refl <- withTypes (vectorLength a) (vectorLength b) <$> eqT
392 return Refl
393 geq a@(IsGLMatrix x) b@(IsGLMatrix y) = do
394 Refl <- geq x y
395 let (ar,ac) = matrixDimensions a
396 (br,bc) = matrixDimensions b
397 Refl <- withTypes (asTypeOf ar RowCount) (asTypeOf br RowCount) <$> eqT
398 Refl <- withTypes (asTypeOf ac ColumnCount) (asTypeOf bc ColumnCount) <$> eqT
399 return Refl
400 geq _ _ = Nothing
401
402instance GCompare GLABI where
403 gcompare IsGLVector{} IsGLMatrix{} = GLT
404 gcompare IsGLMatrix{} IsGLVector{} = GGT
405 gcompare a@(IsGLVector x) b@(IsGLVector y) = case gcompare x y of
406 GLT -> GLT
407 GEQ -> case withTypes (vectorLength a) (vectorLength b) <$> eqT of
408 Just Refl -> GEQ
409 Nothing -> case compare (natVal $ vectorLength a) (natVal $ vectorLength b) of
410 LT -> GLT
411 GT -> GGT
412 GGT -> GGT
413 gcompare a@(IsGLMatrix x) b@(IsGLMatrix y) = case gcompare x y of
414 GLT -> GLT
415 GEQ -> case matrixDimensions a of
416 (ar,ac) -> case matrixDimensions b of
417 (br,bc) -> case withTypes ar br <$> eqT of
418 Just Refl -> case withTypes ac bc <$> eqT of
419 Just Refl -> GEQ
420 Nothing -> if natVal ac < natVal bc then GLT else GGT
421 Nothing -> if natVal ar < natVal br then GLT else GGT
422 GGT -> GGT
423
424
425-- | Run-time encoding of the type of passed pointer to the OpenGL api for a
426-- given uniform.
427data GLPointerType typ where
428 GLPrimUInt :: GLPointerType Word32
429 GLPrimInt :: GLPointerType Int32
430 GLPrimFloat :: GLPointerType Float
431
432deriving instance Show (GLPointerType typ)
433
434instance GEq GLPointerType where
435 geq GLPrimUInt GLPrimUInt = Just Refl
436 geq GLPrimInt GLPrimInt = Just Refl
437 geq GLPrimFloat GLPrimFloat = Just Refl
438
439instance GCompare GLPointerType where
440 gcompare GLPrimUInt GLPrimUInt = GEQ
441 gcompare GLPrimUInt _ = GLT
442 gcompare GLPrimFloat GLPrimFloat = GEQ
443 gcompare GLPrimFloat _ = GGT
444 gcompare GLPrimInt GLPrimUInt = GLT
445 gcompare GLPrimInt GLPrimInt = GEQ
446 gcompare GLPrimInt GLPrimFloat = GGT
447
448-- | Convenience proxy for the number of dimensions in a vector.
449data VectorLength (n :: Nat) = VectorLength
450
451-- | Extract the number of dimensions in a vector from a 'GLABI'.
452vectorLength :: GLABI (GLVector n typ) -> VectorLength n
453vectorLength IsGLVector{} = VectorLength
454
455-- | Convenience proxy for the number of rows in a matrix.
456data RowCount (n :: Nat) = RowCount
457
458-- | Convenience proxy for the number of columns in a matrix.
459data ColumnCount (n :: Nat) = ColumnCount
460
461-- | Extract row and column counts from a 'GLABI'.
462matrixDimensions :: GLABI (GLMatrix r c typ) -> (RowCount r, ColumnCount c)
463matrixDimensions IsGLMatrix{} = (RowCount,ColumnCount)
464
465-- | Convenience accessor for the pointer type proxy of a 'GLABI'.
466ptrType :: GLABI (f t) -> GLPointerType t
467ptrType (IsGLVector p) = p
468ptrType (IsGLMatrix p) = p
469
470
471-- | Provides a pointer and element count to a given continuation.
472--
473-- If the pointer refers to matrix data, then a 'GLboolean' is also passed.
474-- This is GL_TRUE when the matrix data is in row-major format (i.e. matrix
475-- rows are contiguous blocks of memory.)
476data MarshalGL c where
477
478 MarshalGLVector :: (forall b. (GLsizei -> Ptr typ -> IO b) -> IO b)
479 -> MarshalGL (GLVector n typ)
480
481 MarshalGLMatrix :: (forall b. (GLsizei -> GLboolean -> Ptr typ -> IO b) -> IO b)
482 -> MarshalGL (GLMatrix r c typ)
483
484
485-- | Obtain a type-level description for a given input context. This is
486-- similar to 'glUniform' except that it is used only as description and does
487-- not provide the actual OpenGL API function.
488glABI :: TypeTag a -> GLABI a
489glABI TypeBool = IsGLVector GLPrimUInt
490glABI TypeWord = IsGLVector GLPrimUInt
491glABI TypeInt = IsGLVector GLPrimInt
492glABI TypeFloat = IsGLVector GLPrimFloat
493glABI TypeV2B = IsGLVector GLPrimUInt
494glABI TypeV2U = IsGLVector GLPrimUInt
495glABI TypeV2I = IsGLVector GLPrimInt
496glABI TypeV2F = IsGLVector GLPrimFloat
497glABI TypeV3B = IsGLVector GLPrimUInt
498glABI TypeV3U = IsGLVector GLPrimUInt
499glABI TypeV3I = IsGLVector GLPrimInt
500glABI TypeV3F = IsGLVector GLPrimFloat
501glABI TypeV4B = IsGLVector GLPrimUInt
502glABI TypeV4U = IsGLVector GLPrimUInt
503glABI TypeV4I = IsGLVector GLPrimInt
504glABI TypeV4F = IsGLVector GLPrimFloat
505glABI TypeM22F = IsGLMatrix GLPrimFloat
506glABI TypeM23F = IsGLMatrix GLPrimFloat
507glABI TypeM24F = IsGLMatrix GLPrimFloat
508glABI TypeM32F = IsGLMatrix GLPrimFloat
509glABI TypeM33F = IsGLMatrix GLPrimFloat
510glABI TypeM34F = IsGLMatrix GLPrimFloat
511glABI TypeM42F = IsGLMatrix GLPrimFloat
512glABI TypeM43F = IsGLMatrix GLPrimFloat
513glABI TypeM44F = IsGLMatrix GLPrimFloat
514
515-- | This is a convenience utility to provide explicit context to
516-- type-equality. For example, to compare types denoted by proxies /a/ and
517-- /b/, use
518--
519-- > case withTypes a b <$> eqT of
520-- > Just Refl -> typesAreEqual
521-- > Nothing -> typesArenotEqual
522--
523-- This utility is not OpenGL related, but it is used by the GCompare instances
524-- implemented here.
525withTypes :: p (a::k) -> q (b::k) -> f a b -> f a b
526withTypes _ _ x = x
527
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index bd3f827..97b8e25 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -5,6 +5,7 @@ import Data.IORef
5import Data.Int 5import Data.Int
6import Data.IntMap.Strict (IntMap) 6import Data.IntMap.Strict (IntMap)
7import Data.Set (Set) 7import Data.Set (Set)
8import Data.Typeable
8import Data.Map (Map) 9import Data.Map (Map)
9import Data.Vector (Vector) 10import Data.Vector (Vector)
10import Data.Word 11import Data.Word
@@ -14,11 +15,12 @@ import Data.ByteString
14 15
15import Graphics.GL.Core33 16import Graphics.GL.Core33
16 17
17import LambdaCube.Linear 18import LambdaCube.GL.Input.Type
18import LambdaCube.IR 19import LambdaCube.IR
20import LambdaCube.Linear
19import LambdaCube.PipelineSchema 21import LambdaCube.PipelineSchema
20 22
21type GLUniformName = ByteString 23type GLUniformName = String
22 24
23--------------- 25---------------
24-- Input API -- 26-- Input API --
@@ -67,10 +69,21 @@ data ArrayDesc
67 - independent from pipeline 69 - independent from pipeline
68 - per object features: enable/disable visibility, set render ordering 70 - per object features: enable/disable visibility, set render ordering
69-} 71-}
70data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a) 72data GLUniform = forall c. Typeable c => GLTypedUniform (TypeTag c) (IORef (GLUniformValue c))
73 | GLUniform !InputType !(IORef TextureData)
74
75data GLUniformValue c = forall a. GLData a c => GLUniformValue a
71 76
72instance Show GLUniform where 77instance Show GLUniform where
73 show (GLUniform t _) = "GLUniform " ++ show t 78 showsPrec d (GLTypedUniform t _) = paren '('
79 . mappend "GLUniform "
80 . showsPrec (d+10) (unwitnessType t)
81 . paren ')'
82 where paren | d<=10 = (:)
83 | otherwise = \_ -> id
84 showsPrec d (GLUniform t _) = paren '(' . mappend "GLUniform " . showsPrec (d+10) t . paren ')'
85 where paren | d<=10 = (:)
86 | otherwise = \_ -> id
74 87
75data OrderJob 88data OrderJob
76 = Generate 89 = Generate
@@ -90,7 +103,6 @@ data GLStorage
90 , slotMap :: Map String SlotName 103 , slotMap :: Map String SlotName
91 , slotVector :: Vector (IORef GLSlot) 104 , slotVector :: Vector (IORef GLSlot)
92 , objSeed :: IORef Int 105 , objSeed :: IORef Int
93 , uniformSetter :: Map GLUniformName InputSetter
94 , uniformSetup :: Map String GLUniform 106 , uniformSetup :: Map String GLUniform
95 , screenSize :: IORef (Word,Word) 107 , screenSize :: IORef (Word,Word)
96 , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines 108 , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines
@@ -102,7 +114,6 @@ data Object -- internal type
102 , objPrimitive :: Primitive 114 , objPrimitive :: Primitive
103 , objIndices :: Maybe (IndexStream Buffer) 115 , objIndices :: Maybe (IndexStream Buffer)
104 , objAttributes :: Map String (Stream Buffer) 116 , objAttributes :: Map String (Stream Buffer)
105 , objUniSetter :: Map GLUniformName InputSetter
106 , objUniSetup :: Map String GLUniform 117 , objUniSetup :: Map String GLUniform
107 , objOrder :: IORef Int 118 , objOrder :: IORef Int
108 , objEnabled :: IORef Bool 119 , objEnabled :: IORef Bool
@@ -232,72 +243,7 @@ data GLObjectCommand
232type SetterFun a = a -> IO () 243type SetterFun a = a -> IO ()
233 244
234-- user will provide scalar input data via this type 245-- user will provide scalar input data via this type
235data InputSetter 246type InputSetter = GLUniform
236 = SBool (SetterFun Bool)
237 | SV2B (SetterFun V2B)
238 | SV3B (SetterFun V3B)
239 | SV4B (SetterFun V4B)
240 | SWord (SetterFun Word32)
241 | SV2U (SetterFun V2U)
242 | SV3U (SetterFun V3U)
243 | SV4U (SetterFun V4U)
244 | SInt (SetterFun Int32)
245 | SV2I (SetterFun V2I)
246 | SV3I (SetterFun V3I)
247 | SV4I (SetterFun V4I)
248 | SFloat (SetterFun Float)
249 | SV2F (SetterFun V2F)
250 | SV3F (SetterFun V3F)
251 | SV4F (SetterFun V4F)
252 | SM22F (SetterFun M22F)
253 | SM23F (SetterFun M23F)
254 | SM24F (SetterFun M24F)
255 | SM32F (SetterFun M32F)
256 | SM33F (SetterFun M33F)
257 | SM34F (SetterFun M34F)
258 | SM42F (SetterFun M42F)
259 | SM43F (SetterFun M43F)
260 | SM44F (SetterFun M44F)
261 -- shadow textures
262 | SSTexture1D
263 | SSTexture2D
264 | SSTextureCube
265 | SSTexture1DArray
266 | SSTexture2DArray
267 | SSTexture2DRect
268 -- float textures
269 | SFTexture1D
270 | SFTexture2D (SetterFun TextureData)
271 | SFTexture3D
272 | SFTextureCube
273 | SFTexture1DArray
274 | SFTexture2DArray
275 | SFTexture2DMS
276 | SFTexture2DMSArray
277 | SFTextureBuffer
278 | SFTexture2DRect
279 -- int textures
280 | SITexture1D
281 | SITexture2D
282 | SITexture3D
283 | SITextureCube
284 | SITexture1DArray
285 | SITexture2DArray
286 | SITexture2DMS
287 | SITexture2DMSArray
288 | SITextureBuffer
289 | SITexture2DRect
290 -- uint textures
291 | SUTexture1D
292 | SUTexture2D
293 | SUTexture3D
294 | SUTextureCube
295 | SUTexture1DArray
296 | SUTexture2DArray
297 | SUTexture2DMS
298 | SUTexture2DMSArray
299 | SUTextureBuffer
300 | SUTexture2DRect
301 247
302-- buffer handling 248-- buffer handling
303{- 249{-
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index fbc0f50..071e86b 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -1,8 +1,12 @@
1{-# LANGUAGE RecordWildCards #-} 1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE RecordWildCards #-}
2module LambdaCube.GL.Util ( 6module LambdaCube.GL.Util (
3 queryUniforms, 7 queryUniforms,
4 queryStreams, 8 queryStreams,
5 mkUniformSetter, 9 initializeUniform,
6 setUniform, 10 setUniform,
7 setVertexAttrib, 11 setVertexAttrib,
8 compileShader, 12 compileShader,
@@ -28,7 +32,9 @@ module LambdaCube.GL.Util (
28 compileTexture, 32 compileTexture,
29 primitiveToFetchPrimitive, 33 primitiveToFetchPrimitive,
30 primitiveToGLType, 34 primitiveToGLType,
31 inputTypeToTextureTarget 35 inputTypeToTextureTarget,
36 TypeMismatch(..),
37 typeMismatch
32) where 38) where
33 39
34import Control.Applicative 40import Control.Applicative
@@ -43,12 +49,17 @@ import Data.Vector.Unboxed.Mutable (IOVector)
43import qualified Data.Vector.Unboxed.Mutable as MV 49import qualified Data.Vector.Unboxed.Mutable as MV
44import Data.Map (Map) 50import Data.Map (Map)
45import qualified Data.Map as Map 51import qualified Data.Map as Map
52import Data.Typeable
53import Data.Dependent.Sum
54import qualified Data.Dependent.Map as DMap
55import Data.Some
46 56
47import Graphics.GL.Core33 57import Graphics.GL.Core33
48import LambdaCube.Linear 58import LambdaCube.Linear
49import LambdaCube.IR 59import LambdaCube.IR
50import LambdaCube.PipelineSchema 60import LambdaCube.PipelineSchema
51import LambdaCube.GL.Type 61import LambdaCube.GL.Type
62import LambdaCube.GL.Input.Type
52 63
53setSampler :: GLint -> Int32 -> IO () 64setSampler :: GLint -> Int32 -> IO ()
54setSampler i v = glUniform1i i $ fromIntegral v 65setSampler i v = glUniform1i i $ fromIntegral v
@@ -70,67 +81,138 @@ b2w :: Bool -> GLuint
70b2w True = 1 81b2w True = 1
71b2w False = 0 82b2w False = 0
72 83
73mkUniformSetter :: InputType -> IO (GLUniform, InputSetter) 84instance GLData Bool (GLVector 1 GLuint) where
74mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)} 85 marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w b) (f 1)
75mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)} 86instance GLData (V2 Bool) (GLVector 2 GLuint) where
76mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)} 87 marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr)
77mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)} 88instance GLData (V3 Bool) (GLVector 3 GLuint) where
78mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)} 89 marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr)
79mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)} 90instance GLData (V4 Bool) (GLVector 4 GLuint) where
80mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)} 91 marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr)
81mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)} 92instance Uniformable Bool where uniformContexts _ = contexts $ supports TypeBool
82mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)} 93instance Uniformable (V2 Bool) where uniformContexts _ = contexts $ supports TypeV2B
83mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)} 94instance Uniformable (V3 Bool) where uniformContexts _ = contexts $ supports TypeV3B
84mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)} 95instance Uniformable (V4 Bool) where uniformContexts _ = contexts $ supports TypeV4B
85mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)} 96
86mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)} 97instance GLData Word32 (GLVector 1 GLuint)
87mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)} 98instance GLData (V2 Word32) (GLVector 2 GLuint)
88mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)} 99instance GLData (V3 Word32) (GLVector 3 GLuint)
89mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)} 100instance GLData (V4 Word32) (GLVector 4 GLuint)
90mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)} 101instance Uniformable Word32 where uniformContexts _ = contexts $ supports TypeWord
91mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)} 102instance Uniformable (V2 Word32) where uniformContexts _ = contexts $ supports TypeV2U
92mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)} 103instance Uniformable (V3 Word32) where uniformContexts _ = contexts $ supports TypeV3U
93mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)} 104instance Uniformable (V4 Word32) where uniformContexts _ = contexts $ supports TypeV4U
94mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)} 105
95mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)} 106instance GLData Int32 (GLVector 1 GLint)
96mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)} 107instance GLData (V2 Int32) (GLVector 2 GLint)
97mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)} 108instance GLData (V3 Int32) (GLVector 3 GLint)
98mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)} 109instance GLData (V4 Int32) (GLVector 4 GLint)
99mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)} 110instance Uniformable Int32 where uniformContexts _ = contexts $ supports TypeInt
111instance Uniformable (V2 Int32) where uniformContexts _ = contexts $ supports TypeV2I
112instance Uniformable (V3 Int32) where uniformContexts _ = contexts $ supports TypeV3I
113instance Uniformable (V4 Int32) where uniformContexts _ = contexts $ supports TypeV4I
114
115instance GLData Float (GLVector 1 GLfloat)
116instance GLData (V2 Float) (GLVector 2 GLfloat)
117instance GLData (V3 Float) (GLVector 3 GLfloat)
118instance GLData (V4 Float) (GLVector 4 GLfloat)
119instance Uniformable Float where uniformContexts _ = contexts $ supports TypeFloat
120instance Uniformable (V2 Float) where uniformContexts _ = contexts $ supports TypeV2F
121instance Uniformable (V3 Float) where uniformContexts _ = contexts $ supports TypeV3F
122instance Uniformable (V4 Float) where uniformContexts _ = contexts $ supports TypeV4F
123
124instance GLData (V2 V2F) (GLMatrix 2 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
125instance GLData (V3 V2F) (GLMatrix 3 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
126instance GLData (V4 V2F) (GLMatrix 4 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
127instance GLData (V2 V3F) (GLMatrix 2 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
128instance GLData (V3 V3F) (GLMatrix 3 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
129instance GLData (V4 V3F) (GLMatrix 4 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
130instance GLData (V2 V4F) (GLMatrix 2 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
131instance GLData (V3 V4F) (GLMatrix 3 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
132instance GLData (V4 V4F) (GLMatrix 4 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
133instance Uniformable (V2 V2F) where uniformContexts _ = contexts $ supports TypeM22F
134instance Uniformable (V3 V2F) where uniformContexts _ = contexts $ supports TypeM23F
135instance Uniformable (V4 V2F) where uniformContexts _ = contexts $ supports TypeM24F
136instance Uniformable (V2 V3F) where uniformContexts _ = contexts $ supports TypeM32F
137instance Uniformable (V3 V3F) where uniformContexts _ = contexts $ supports TypeM33F
138instance Uniformable (V4 V3F) where uniformContexts _ = contexts $ supports TypeM34F
139instance Uniformable (V2 V4F) where uniformContexts _ = contexts $ supports TypeM42F
140instance Uniformable (V3 V4F) where uniformContexts _ = contexts $ supports TypeM43F
141instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports TypeM44F
142
143
144instance Uniformable TextureData where uniformContexts _ = DMap.empty -- TODO
145
146mkU :: GLData a c => TypeTag c -> a -> IO GLUniform
147mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a)
148
149initializeUniform :: InputType -> IO GLUniform
150initializeUniform t = case witnessType t of
151
152 Just (This ty) -> case ty of
153 TypeBool -> mkU ty False
154 TypeV2B -> mkU ty (V2 False False)
155 TypeV3B -> mkU ty (V3 False False False)
156 TypeV4B -> mkU ty (V4 False False False False)
157 TypeWord -> mkU ty (0::Word32)
158 TypeV2U -> mkU ty (V2 0 0 :: V2 Word32)
159 TypeV3U -> mkU ty (V3 0 0 0 :: V3 Word32)
160 TypeV4U -> mkU ty (V4 0 0 0 0 :: V4 Word32)
161 TypeInt -> mkU ty (0::Int32)
162 TypeV2I -> mkU ty (V2 0 0 :: V2 Int32)
163 TypeV3I -> mkU ty (V3 0 0 0 :: V3 Int32)
164 TypeV4I -> mkU ty (V4 0 0 0 0 :: V4 Int32)
165 TypeFloat -> mkU ty (0::Float)
166 TypeV2F -> mkU ty (V2 0 0 :: V2 Float)
167 TypeV3F -> mkU ty (V3 0 0 0 :: V3 Float)
168 TypeV4F -> mkU ty (V4 0 0 0 0 :: V4 Float)
169 TypeM22F -> mkU ty (V2 z2 z2)
170 TypeM23F -> mkU ty (V3 z2 z2 z2)
171 TypeM24F -> mkU ty (V4 z2 z2 z2 z2)
172 TypeM32F -> mkU ty (V2 z3 z3)
173 TypeM33F -> mkU ty (V3 z3 z3 z3)
174 TypeM34F -> mkU ty (V4 z3 z3 z3 z3)
175 TypeM42F -> mkU ty (V2 z4 z4)
176 TypeM43F -> mkU ty (V3 z4 z4 z4)
177 TypeM44F -> mkU ty (V4 z4 z4 z4 z4)
178
179 Nothing -> case t of
180 FTexture2D -> GLUniform t <$> newIORef (TextureData 0)
181 _ -> fail $ "initializeUniform: " ++ show t
182
183
184data TypeMismatch c a = TypeMismatch
185
186instance (Typeable c, Typeable a) => Show (TypeMismatch c a) where
187 showsPrec d ty =
188 paren '('
189 . mappend "TypeMismatch @"
190 . showsPrec 11 (typeRep $ ctx ty)
191 . mappend " @"
192 . showsPrec 0 (typeRep ty)
193 . paren ')'
194 where
195 ctx :: ty c a -> Proxy c
196 ctx _ = Proxy
197 paren | d<=10 = (:)
198 | otherwise = \_ -> id
199
200instance (Typeable c, Typeable a) => Exception (TypeMismatch c a)
201
202typeMismatch :: ctx c -> ref a -> TypeMismatch c a
203typeMismatch _ _ = TypeMismatch
100 204
101-- sets value based uniforms only (does not handle textures) 205-- sets value based uniforms only (does not handle textures)
102setUniform :: Storable a => GLint -> InputType -> IORef a -> IO () 206setUniform :: GLint -> TypeTag c -> IO (GLUniformValue c) -> IO ()
103setUniform i ty ref = do 207setUniform i ty ref = do
104 v <- readIORef ref 208 GLUniformValue v <- ref
105 let false = fromIntegral GL_FALSE 209 let false = GL_FALSE
106 with v $ \p -> case ty of 210 case marshalUniform (glABI ty) v of
107 Bool -> glUniform1uiv i 1 (castPtr p) 211 Just (MarshalGLVector withU) -> withU $ \n ptr ->
108 V2B -> glUniform2uiv i 1 (castPtr p) 212 case glUniform ty of GLVector f -> f i n ptr
109 V3B -> glUniform3uiv i 1 (castPtr p) 213 Just (MarshalGLMatrix withU) -> withU $ \n isRowMajor ptr ->
110 V4B -> glUniform4uiv i 1 (castPtr p) 214 case glUniform ty of GLMatrix f -> f i n isRowMajor ptr
111 Word -> glUniform1uiv i 1 (castPtr p) 215 Nothing -> throwIO (typeMismatch ty ref)
112 V2U -> glUniform2uiv i 1 (castPtr p)
113 V3U -> glUniform3uiv i 1 (castPtr p)
114 V4U -> glUniform4uiv i 1 (castPtr p)
115 Int -> glUniform1iv i 1 (castPtr p)
116 V2I -> glUniform2iv i 1 (castPtr p)
117 V3I -> glUniform3iv i 1 (castPtr p)
118 V4I -> glUniform4iv i 1 (castPtr p)
119 Float -> glUniform1fv i 1 (castPtr p)
120 V2F -> glUniform2fv i 1 (castPtr p)
121 V3F -> glUniform3fv i 1 (castPtr p)
122 V4F -> glUniform4fv i 1 (castPtr p)
123 M22F -> glUniformMatrix2fv i 1 false (castPtr p)
124 M23F -> glUniformMatrix2x3fv i 1 false (castPtr p)
125 M24F -> glUniformMatrix2x4fv i 1 false (castPtr p)
126 M32F -> glUniformMatrix3x2fv i 1 false (castPtr p)
127 M33F -> glUniformMatrix3fv i 1 false (castPtr p)
128 M34F -> glUniformMatrix3x4fv i 1 false (castPtr p)
129 M42F -> glUniformMatrix4x2fv i 1 false (castPtr p)
130 M43F -> glUniformMatrix4x3fv i 1 false (castPtr p)
131 M44F -> glUniformMatrix4fv i 1 false (castPtr p)
132 FTexture2D -> return () --putStrLn $ "TODO: setUniform FTexture2D"
133 _ -> fail $ "internal error (setUniform)! - " ++ show ty
134 216
135-- attribute functions 217-- attribute functions
136queryStreams :: GLuint -> IO (Map String GLuint, Map String InputType) 218queryStreams :: GLuint -> IO (Map String GLuint, Map String InputType)
@@ -605,6 +687,7 @@ compileTexture txDescriptor = do
605 , textureMaxLevel = txMaxLevel 687 , textureMaxLevel = txMaxLevel
606 } = txDescriptor 688 } = txDescriptor
607 689
690 txSetup :: Num a => GLenum -> TextureDataType -> IO (a,GLenum)
608 txSetup txTarget dTy = do 691 txSetup txTarget dTy = do
609 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy 692 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy
610 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy 693 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy