vinyl-gl 0.2.1 → 0.3
raw patch · 5 files changed
+79/−74 lines, 5 filesdep ~vinyl
Dependency ranges changed: vinyl
Files
- src/Data/Vinyl/Reflect.hs +14/−15
- src/Graphics/VinylGL/Uniforms.hs +23/−25
- src/Graphics/VinylGL/Vertex.hs +36/−25
- tests/BasicTest.hs +4/−7
- vinyl-gl.cabal +2/−2
src/Data/Vinyl/Reflect.hs view
@@ -4,8 +4,7 @@ module Data.Vinyl.Reflect where import Data.Foldable (Foldable, foldMap) import Data.Monoid (Sum(..))-import Data.Vinyl (FieldRec, PlainFieldRec)-import Data.Vinyl.Universe ((:::))+import Data.Vinyl (FieldRec) import Foreign.Storable (Storable(sizeOf)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 import Data.Proxy@@ -16,17 +15,17 @@ class HasFieldNames a where fieldNames :: a -> [String] -instance HasFieldNames (FieldRec f '[]) where+instance HasFieldNames (FieldRec '[]) where fieldNames _ = [] #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-instance (KnownSymbol sy, HasFieldNames (PlainFieldRec ts))- => HasFieldNames (PlainFieldRec (((sy::Symbol):::t) ': ts)) where+instance (KnownSymbol sy, HasFieldNames (FieldRec ts))+ => HasFieldNames (FieldRec ('((sy::Symbol), t) ': ts)) where fieldNames _ = symbolVal (Proxy::Proxy sy)- : fieldNames (undefined::PlainFieldRec ts)+ : fieldNames (undefined::FieldRec ts) #else instance (SingI sy, HasFieldNames (PlainFieldRec ts))- => HasFieldNames (PlainFieldRec (((sy::Symbol):::t) ': ts)) where+ => HasFieldNames (FieldRec ('((sy::Symbol),t) ': ts)) where fieldNames _ = fromSing (sing::Sing sy) : fieldNames (undefined::PlainFieldRec ts) #endif@@ -35,13 +34,13 @@ class HasFieldSizes a where fieldSizes :: a -> [Int] -instance HasFieldSizes (FieldRec f '[]) where+instance HasFieldSizes (FieldRec '[]) where fieldSizes _ = [] -instance (HasFieldSizes (PlainFieldRec ts), Storable t)- => HasFieldSizes (PlainFieldRec (((sy::Symbol) ::: t) ': ts)) where+instance (HasFieldSizes (FieldRec ts), Storable t)+ => HasFieldSizes (FieldRec ('((sy::Symbol), t) ': ts)) where fieldSizes _ = sizeOf (undefined::t)- : fieldSizes (undefined::PlainFieldRec ts)+ : fieldSizes (undefined::FieldRec ts) -- | Compute the dimensionality of each field in a record. This is -- primarily useful for things like the small finite vector types@@ -49,10 +48,10 @@ class HasFieldDims a where fieldDims :: a -> [Int] -instance HasFieldDims (FieldRec f '[]) where+instance HasFieldDims (FieldRec '[]) where fieldDims _ = [] -instance (HasFieldDims (PlainFieldRec ts), Foldable v, Num (v a))- => HasFieldDims (PlainFieldRec ((sy::Symbol):::v a ': ts)) where+instance (HasFieldDims (FieldRec ts), Foldable v, Num (v a))+ => HasFieldDims (FieldRec ('((sy::Symbol), v a) ': ts)) where fieldDims _ = getSum (foldMap (const (Sum 1)) (0::v a))- : fieldDims (undefined::PlainFieldRec ts)+ : fieldDims (undefined::FieldRec ts)
src/Graphics/VinylGL/Uniforms.hs view
@@ -14,10 +14,8 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified Data.Set as S-import Data.Vinyl (FieldRec, PlainFieldRec, Rec(..))-import Data.Vinyl.Idiom.Identity+import Data.Vinyl (FieldRec, ElField(..), Rec(..)) import Data.Vinyl.Reflect (HasFieldNames(..))-import Data.Vinyl.Universe ((:::)) import GHC.TypeLits (Symbol) import Graphics.GLUtil (HasVariableType(..), ShaderProgram(..), AsUniform(..)) import Graphics.Rendering.OpenGL as GL@@ -27,15 +25,15 @@ class HasFieldGLTypes a where fieldGLTypes :: a -> [GL.VariableType] -instance HasFieldGLTypes (FieldRec f '[]) where+instance HasFieldGLTypes (FieldRec '[]) where fieldGLTypes _ = [] -instance (HasVariableType t, HasFieldGLTypes (PlainFieldRec ts))- => HasFieldGLTypes (PlainFieldRec ((sy::Symbol):::t ': ts)) where+instance (HasVariableType t, HasFieldGLTypes (FieldRec ts))+ => HasFieldGLTypes (FieldRec ('((sy::Symbol), t) ': ts)) where fieldGLTypes _ = variableType (undefined::t) - : fieldGLTypes (undefined::PlainFieldRec ts)+ : fieldGLTypes (undefined::FieldRec ts) --- | Constraint synonym for 'PlainFieldRec's that carry valid GLSL+-- | Constraint synonym for 'FieldRec's that carry valid GLSL -- uniforms. type UniformFields a = (HasFieldNames a, HasFieldGLTypes a, SetUniformFields a) @@ -43,45 +41,45 @@ -- performed to verify that /all/ uniforms used by a program are -- represented by the record type. In other words, the record is a -- superset of the parameters used by the program.-setAllUniforms :: forall ts. UniformFields (PlainFieldRec ts)- => ShaderProgram -> PlainFieldRec ts -> IO ()+setAllUniforms :: forall ts. UniformFields (FieldRec ts)+ => ShaderProgram -> FieldRec ts -> IO () setAllUniforms s x = case checks of Left msg -> error msg Right _ -> setUniformFields locs x- where fnames = fieldNames (undefined::PlainFieldRec ts)+ where fnames = fieldNames (undefined::FieldRec ts) checks = do namesCheck "record" (M.keys $ uniforms s) fnames typesCheck True (snd <$> uniforms s) fieldTypes fieldTypes = M.fromList $- zip fnames (fieldGLTypes (undefined::PlainFieldRec ts))+ zip fnames (fieldGLTypes (undefined::FieldRec ts)) locs = map (fmap fst . (`M.lookup` uniforms s)) fnames {-# INLINE setAllUniforms #-} -- | Set GLSL uniform parameters from a 'PlainRec' representing a -- subset of all uniform parameters used by a program.-setUniforms :: forall ts. UniformFields (PlainFieldRec ts)- => ShaderProgram -> PlainFieldRec ts -> IO ()+setUniforms :: forall ts. UniformFields (FieldRec ts)+ => ShaderProgram -> FieldRec ts -> IO () setUniforms s x = case checks of Left msg -> error msg Right _ -> setUniformFields locs x- where fnames = fieldNames (undefined::PlainFieldRec ts)+ where fnames = fieldNames (undefined::FieldRec ts) checks = do namesCheck "GLSL program" fnames (M.keys $ uniforms s) typesCheck False fieldTypes (snd <$> uniforms s) fieldTypes = M.fromList $- zip fnames (fieldGLTypes (undefined::PlainFieldRec ts))+ zip fnames (fieldGLTypes (undefined::FieldRec ts)) locs = map (fmap fst . (`M.lookup` uniforms s)) fnames {-# INLINE setUniforms #-} -- | Set GLSL uniform parameters from those fields of a 'PlainRec' -- whose names correspond to uniform parameters used by a program.-setSomeUniforms :: forall ts. UniformFields (PlainFieldRec ts)- => ShaderProgram -> PlainFieldRec ts -> IO ()+setSomeUniforms :: forall ts. UniformFields (FieldRec ts)+ => ShaderProgram -> FieldRec ts -> IO () setSomeUniforms s x = case typesCheck' True (snd <$> uniforms s) fieldTypes of Left msg -> error msg Right _ -> setUniformFields locs x- where fnames = fieldNames (undefined::PlainFieldRec ts)+ where fnames = fieldNames (undefined::FieldRec ts) {-# INLINE fnames #-} fieldTypes = M.fromList . zip fnames $- fieldGLTypes (undefined::PlainFieldRec ts)+ fieldGLTypes (undefined::FieldRec ts) {-# INLINE fieldTypes #-} locs = map (fmap fst . (`M.lookup` uniforms s)) fnames {-# INLINE locs #-}@@ -141,19 +139,19 @@ glTypeEquiv :: VariableType -> VariableType -> Bool glTypeEquiv x y = glTypeEquiv' x y || glTypeEquiv' y x --- | Zips up lists of 'UniformLocation's and a 'PlainFieldRec' setting+-- | Zips up lists of 'UniformLocation's and a 'FieldRec' setting -- uniform parameters using the record fields. class SetUniformFields a where setUniformFields :: [Maybe UniformLocation] -> a -> IO () -instance SetUniformFields (FieldRec f '[]) where+instance SetUniformFields (FieldRec '[]) where setUniformFields _ _ = return () {-# INLINE setUniformFields #-} -instance (AsUniform t, SetUniformFields (PlainFieldRec ts))- => SetUniformFields (PlainFieldRec (((sy::Symbol):::t) ': ts)) where+instance (AsUniform t, SetUniformFields (FieldRec ts))+ => SetUniformFields (FieldRec ('((sy::Symbol), t) ': ts)) where setUniformFields [] _ = error "Ran out of UniformLocations"- setUniformFields (loc:locs) (Identity x :& xs) = + setUniformFields (loc:locs) (Field x :& xs) = do traverse_ (asUniform x) loc setUniformFields locs xs {-# INLINABLE setUniformFields #-}
src/Graphics/VinylGL/Vertex.hs view
@@ -1,6 +1,16 @@-{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators, GADTs, BangPatterns,- FlexibleInstances, FlexibleContexts, KindSignatures, RankNTypes,- ConstraintKinds, CPP #-}+{-# LANGUAGE BangPatterns,+ CPP,+ ConstraintKinds,+ DataKinds,+ FlexibleContexts,+ FlexibleInstances,+ GADTs,+ KindSignatures,+ RankNTypes,+ ScopedTypeVariables,+ TypeFamilies,+ TypeOperators #-}+ -- | Utilities for working with vertex buffer objects (VBOs) filled -- with vertices represented as vinyl records. module Graphics.VinylGL.Vertex (bufferVertices, bindVertices, reloadVertices,@@ -15,8 +25,7 @@ import Data.Monoid (Sum(..)) import Data.Proxy (Proxy(..)) import qualified Data.Vector.Storable as V-import Data.Vinyl (PlainFieldRec, Implicit(..), Elem)-import Data.Vinyl.Universe((:::))+import Data.Vinyl (FieldRec, RElem) import Foreign.Ptr (plusPtr) import Foreign.Storable import GHC.TypeLits@@ -29,18 +38,20 @@ import Graphics.VinylGL.Uniforms -- | Representation of a VBO whose type describes the vertices.-newtype BufferedVertices (fields::[*]) = +newtype BufferedVertices (fields::[(Symbol, *)]) = BufferedVertices { getVertexBuffer :: GL.BufferObject } -- | Load vertex data into a GPU-accessible buffer.-bufferVertices :: (Storable (PlainFieldRec rs),- BufferSource (v (PlainFieldRec rs)))- => v (PlainFieldRec rs) -> IO (BufferedVertices rs)+bufferVertices :: (Storable (FieldRec rs),+ BufferSource (v (FieldRec rs)))+ => v (FieldRec rs) -> IO (BufferedVertices rs) bufferVertices = fmap BufferedVertices . fromSource ArrayBuffer -- | Reload 'BufferedVertices' with a 'V.Vector' of new vertex data.-reloadVertices :: Storable (PlainFieldRec rs)- => BufferedVertices rs -> V.Vector (PlainFieldRec rs) -> IO ()+reloadVertices :: Storable (FieldRec rs)+ => BufferedVertices rs+ -> V.Vector (FieldRec rs)+ -> IO () reloadVertices b v = do bindBuffer ArrayBuffer $= Just (getVertexBuffer b) replaceVector ArrayBuffer v @@ -55,39 +66,39 @@ -- | Line up a shader's attribute inputs with a vertex record. This -- maps vertex fields to GLSL attributes on the basis of record field -- names on the Haskell side, and variable names on the GLSL side.-enableVertices :: forall f rs. ViableVertex (PlainFieldRec rs)+enableVertices :: forall f rs. ViableVertex (FieldRec rs) => ShaderProgram -> f rs -> IO (Maybe String)-enableVertices s _ = enableAttribs s (Proxy::Proxy (PlainFieldRec rs))+enableVertices s _ = enableAttribs s (Proxy::Proxy (FieldRec rs)) -- | Behaves like 'enableVertices', but raises an exception if the -- supplied vertex record does not include a field required by the -- shader.-enableVertices' :: forall f rs. ViableVertex (PlainFieldRec rs)+enableVertices' :: forall f rs. ViableVertex (FieldRec rs) => ShaderProgram -> f rs -> IO ()-enableVertices' s _ = enableAttribs s (Proxy::Proxy (PlainFieldRec rs)) >>=+enableVertices' s _ = enableAttribs s (Proxy::Proxy (FieldRec rs)) >>= maybe (return ()) error -- | Produce a 'GL.VertexArrayDescriptor' for a particular field of a -- vertex record.-fieldToVAD :: forall sy v a r rs field proxy.- (r ~ ((sy :: Symbol) ::: v a), HasFieldNames (PlainFieldRec rs), - HasFieldSizes (PlainFieldRec rs), HasGLType a,- Storable (PlainFieldRec rs), Num (v a),+fieldToVAD :: forall sy v a r rs field proxy is.+ (r ~ '((sy :: Symbol), v a), HasFieldNames (FieldRec rs), + HasFieldSizes (FieldRec rs), HasGLType a,+ Storable (FieldRec rs), Num (v a), #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 KnownSymbol sy, #else SingI sy, #endif- Foldable v, Implicit (Elem r rs)) =>- field r -> proxy (PlainFieldRec rs) -> GL.VertexArrayDescriptor a+ Foldable v, RElem r rs is) =>+ field r -> proxy (FieldRec rs) -> GL.VertexArrayDescriptor a fieldToVAD _ _ = GL.VertexArrayDescriptor dim (glType (undefined::a)) (fromIntegral sz) (offset0 `plusPtr` offset)- where sz = sizeOf (undefined::PlainFieldRec rs)+ where sz = sizeOf (undefined::FieldRec rs) dim = getSum $ foldMap (const (Sum 1)) (0::v a) Just offset = lookup n $- namesAndOffsets (undefined::PlainFieldRec rs)+ namesAndOffsets (undefined::FieldRec rs) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 n = symbolVal (Proxy::Proxy sy) #else@@ -101,10 +112,10 @@ -- | Bind some of a shader's attribute inputs to a vertex record. This -- is useful when the inputs of a shader are split across multiple -- arrays.-enableVertexFields :: forall p rs. (ViableVertex (PlainFieldRec rs))+enableVertexFields :: forall p rs. (ViableVertex (FieldRec rs)) => ShaderProgram -> p rs -> IO () enableVertexFields s _ = enableSomeAttribs s p >>= maybe (return ()) error- where p = Proxy :: Proxy (PlainFieldRec rs)+ where p = Proxy :: Proxy (FieldRec rs) -- | Do not raise an error is some of a shader's inputs are not bound -- by a vertex record.
tests/BasicTest.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE DataKinds, KindSignatures, TypeOperators #-}-import Data.Proxy import Data.Vinyl-import Data.Vinyl.Universe import Data.Word import Foreign.Ptr (nullPtr, plusPtr) import Graphics.Rendering.OpenGL (DataType(..), GLfloat,@@ -12,18 +10,17 @@ import Test.Framework.Providers.HUnit (hUnitTestToTests) import Test.HUnit (Test(..), (~=?)) -type Pos = "vpos" ::: V3 GLfloat-type Tag = "tagByte" ::: V1 Word8+type Pos = '("vpos", V3 GLfloat)+type Tag = '("tagByte", V1 Word8) tag :: SField Tag tag = SField -type Vertex = PlainFieldRec [Pos, Tag]+type Vertex = FieldRec [Pos, Tag] ---testVad :: VertexArrayDescriptor Word8 testVad :: Test testVad = TestLabel "Sample VAD Creation" $- vad ~=? fieldToVAD tag (Proxy::Proxy Vertex)+ vad ~=? fieldToVAD tag (SField::SField Vertex) where vad = VertexArrayDescriptor 1 UnsignedByte 13 (nullPtr `plusPtr` 12) main :: IO ()
vinyl-gl.cabal view
@@ -1,5 +1,5 @@ name: vinyl-gl-version: 0.2.1+version: 0.3 synopsis: Utilities for working with OpenGL's GLSL shading language and vinyl records. description: Using "Data.Vinyl" records (similar in spirit to @HList@) to carry GLSL uniform parameters and vertex data enables@@ -28,7 +28,7 @@ Graphics.VinylGL.Vertex -- other-modules: build-depends: base >= 4.6 && < 5, transformers >= 0.3, - vinyl >= 0.4.2 && < 0.5,+ vinyl >= 0.5.1 && < 0.6, containers >= 0.5, GLUtil >= 0.6.4, OpenGL >= 2.8, tagged >= 0.4, vector >= 0.10, linear >= 1.1.3 hs-source-dirs: src