vinyl-gl (empty) → 0.1.0.0
raw patch · 8 files changed
+436/−0 lines, 8 filesdep +GLUtildep +HUnitdep +OpenGLsetup-changed
Dependencies added: GLUtil, HUnit, OpenGL, base, containers, linear, tagged, test-framework, test-framework-hunit, transformers, vector, vinyl, vinyl-gl
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Data/Vinyl/Reflect.hs +46/−0
- src/Graphics/VinylGL.hs +5/−0
- src/Graphics/VinylGL/Uniforms.hs +152/−0
- src/Graphics/VinylGL/Vertex.hs +126/−0
- tests/BasicTest.hs +32/−0
- vinyl-gl.cabal +43/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Anthony Cowley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Anthony Cowley nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Vinyl/Reflect.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds, TypeOperators, FlexibleContexts, FlexibleInstances, + ScopedTypeVariables #-}+-- | Reflection utilities for vinyl records.+module Data.Vinyl.Reflect where+import Data.Foldable (Foldable, foldMap)+import Data.Functor.Identity+import Data.Monoid (Sum(..))+import Data.Vinyl (Rec, PlainRec, (:::))+import Foreign.Storable (Storable(sizeOf))+import GHC.TypeLits (SingI(..), fromSing, Sing)++-- | List all field names in a record.+class HasFieldNames a where+ fieldNames :: a -> [String]++instance HasFieldNames (Rec '[] f) where+ fieldNames _ = []++instance (SingI sy, HasFieldNames (Rec ts Identity))+ => HasFieldNames (Rec ((sy:::t) ': ts) Identity) where+ fieldNames _ = fromSing (sing::Sing sy) : fieldNames (undefined::PlainRec ts)++-- | Compute the size in bytes of of each field in a record.+class HasFieldSizes a where+ fieldSizes :: a -> [Int]++instance HasFieldSizes (Rec '[] f) where+ fieldSizes _ = []++instance (HasFieldSizes (Rec ts Identity), Storable t)+ => HasFieldSizes (Rec ((sy:::t) ': ts) Identity) where+ fieldSizes _ = sizeOf (undefined::t) : fieldSizes (undefined::PlainRec ts)++-- | Compute the dimensionality of each field in a record. This is+-- primarily useful for things like the small finite vector types+-- provided by "Linear".+class HasFieldDims a where+ fieldDims :: a -> [Int]++instance HasFieldDims (Rec '[] f) where+ fieldDims _ = []++instance (HasFieldDims (PlainRec ts), Foldable v, Num (v a))+ => HasFieldDims (PlainRec (sy:::v a ': ts)) where+ fieldDims _ = getSum (foldMap (const (Sum 1)) (0::v a))+ : fieldDims (undefined::PlainRec ts)
+ src/Graphics/VinylGL.hs view
@@ -0,0 +1,5 @@+module Graphics.VinylGL (module Graphics.VinylGL.Uniforms,+ module Graphics.VinylGL.Vertex) + where+import Graphics.VinylGL.Uniforms+import Graphics.VinylGL.Vertex
+ src/Graphics/VinylGL/Uniforms.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE DataKinds, TypeOperators, FlexibleContexts, FlexibleInstances,+ GADTs, ScopedTypeVariables, ConstraintKinds #-}+-- | Tools for binding vinyl records to GLSL program uniform+-- parameters. The most common usage is to use the 'setUniforms'+-- function to set each field of a 'PlainRec' to the GLSL uniform+-- parameter with the same name. This verifies that each field of the+-- record corresponds to a uniform parameter of the given shader+-- program, and that the types all agree.+module Graphics.VinylGL.Uniforms (setAllUniforms, setSomeUniforms, setUniforms,+ HasFieldGLTypes(..)) where+import Control.Applicative ((<$>))+import Data.Foldable (traverse_)+import Data.Functor.Identity+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+import Data.Vinyl+import Graphics.GLUtil (HasVariableType(..), ShaderProgram(..), AsUniform(..))+import Graphics.Rendering.OpenGL as GL+import Data.Vinyl.Reflect (HasFieldNames(..))++-- | Provide the 'GL.VariableType' of each field in a 'Rec'. The list+-- of types has the same order as the fields of the 'Rec'.+class HasFieldGLTypes a where+ fieldGLTypes :: a -> [GL.VariableType]++instance HasFieldGLTypes (Rec '[] f) where+ fieldGLTypes _ = []++instance (HasVariableType t, HasFieldGLTypes (PlainRec ts))+ => HasFieldGLTypes (PlainRec (sy:::t ': ts)) where+ fieldGLTypes _ = variableType (undefined::t) + : fieldGLTypes (undefined::PlainRec ts)++type UniformFields a = (HasFieldNames a, HasFieldGLTypes a, SetUniformFields a)++-- | Set GLSL uniform parameters from a 'PlainRec'. A check is+-- 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 (PlainRec ts)+ => ShaderProgram -> PlainRec ts -> IO ()+setAllUniforms s x = case checks of+ Left msg -> error msg+ Right _ -> setUniformFields locs x+ where fnames = fieldNames (undefined::PlainRec ts)+ checks = do namesCheck "record" (M.keys $ uniforms s) fnames+ typesCheck True (snd <$> uniforms s) fieldTypes+ fieldTypes = M.fromList $+ zip fnames (fieldGLTypes (undefined::PlainRec 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 (PlainRec ts)+ => ShaderProgram -> PlainRec ts -> IO ()+setUniforms s x = case checks of+ Left msg -> error msg+ Right _ -> setUniformFields locs x+ where fnames = fieldNames (undefined::PlainRec ts)+ checks = do namesCheck "GLSL program" fnames (M.keys $ uniforms s)+ typesCheck False fieldTypes (snd <$> uniforms s)+ fieldTypes = M.fromList $+ zip fnames (fieldGLTypes (undefined::PlainRec 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 (PlainRec ts)+ => ShaderProgram -> PlainRec 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::PlainRec ts)+ {-# INLINE fnames #-}+ fieldTypes = M.fromList . zip fnames $+ fieldGLTypes (undefined::PlainRec ts)+ {-# INLINE fieldTypes #-}+ locs = map (fmap fst . (`M.lookup` uniforms s)) fnames+ {-# INLINE locs #-}+{-# INLINE setSomeUniforms #-}++-- | @namesCheck blame little big@ checks that each name in @little@ is+-- an element of @big@.+namesCheck :: String -> [String] -> [String] -> Either String ()+namesCheck blame little big = mapM_ aux little+ where big' = S.fromList big+ aux x | x `S.member` big' = Right ()+ | otherwise = Left $ "Field "++x++" not found in "++blame++-- | @typesChecks blame little big@ checks that each (name,type) pair+-- in @little@ is a member of @big@.+typesCheck :: Bool+ -> M.Map String GL.VariableType -> M.Map String GL.VariableType+ -> Either String ()+typesCheck blame little big = mapM_ aux $ M.toList little+ where aux (n,t)+ | Just True == (glTypeEquiv t <$> M.lookup n big) = return ()+ | otherwise = Left $ msg n (show t) (maybe "" show (M.lookup n big))+ msg n t t' = let (expected, actual) = if blame+ then (t,t')+ else (t',t)+ in "Record and GLSL type disagreement on field "++n+++ ": GLSL expected "++expected+++ ", record provides "++actual++-- | @typesCheck' blame little big@ checks that each (name,type) pair+-- in the intersection of @little@ and @big@ is consistent.+typesCheck' :: Bool+ -> M.Map String GL.VariableType -> M.Map String GL.VariableType+ -> Either String ()+typesCheck' blame little big = mapM_ aux $ M.toList little+ where aux (n,t)+ | fromMaybe True (glTypeEquiv t <$> M.lookup n big) = return ()+ | otherwise = Left $ msg n (show t) (maybe "" show (M.lookup n big))+ msg n t t' = let (expected, actual) = if blame+ then (t,t')+ else (t',t)+ in "Record and GLSL type disagreement on field "++n+++ ": GLSL expected "++expected+++ ", record provides "++actual++-- The equivalence on 'GL.VariableType's we need identifies Samplers+-- with Ints because this is how GLSL represents samplers.+glTypeEquiv' :: GL.VariableType -> GL.VariableType -> Bool+glTypeEquiv' GL.Sampler1D GL.Int' = True+glTypeEquiv' GL.Sampler2D GL.Int' = True+glTypeEquiv' GL.Sampler3D GL.Int' = True+glTypeEquiv' x y = x == y++-- We define our own equivalence relation on types because we don't+-- have unique Haskell representations for every GL type. For example,+-- the GLSL sampler types (e.g. Sampler2D) are just GLint in Haskell.+glTypeEquiv :: VariableType -> VariableType -> Bool+glTypeEquiv x y = glTypeEquiv' x y || glTypeEquiv' y x++class SetUniformFields a where+ setUniformFields :: [Maybe UniformLocation] -> a -> IO ()++instance SetUniformFields (Rec '[] f) where+ setUniformFields _ _ = return ()+ {-# INLINE setUniformFields #-}++instance (AsUniform t, SetUniformFields (PlainRec ts))+ => SetUniformFields (PlainRec ((sy:::t) ': ts)) where+ setUniformFields [] _ = error "Ran out of UniformLocations"+ setUniformFields (loc:locs) (Identity x :& xs) = + do traverse_ (asUniform x) loc+ setUniformFields locs xs+ {-# INLINABLE setUniformFields #-}
+ src/Graphics/VinylGL/Vertex.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators, GADTs, BangPatterns,+ FlexibleInstances, FlexibleContexts, KindSignatures, RankNTypes,+ ConstraintKinds #-}+-- | Utilities for working with vertex buffer objects (VBOs) filled+-- with vertices represented as vinyl records.+module Graphics.VinylGL.Vertex (bufferVertices, bindVertices, reloadVertices,+ deleteVertices, enableVertices, enableVertices',+ BufferedVertices(..), fieldToVAD) where+import Control.Applicative+import Control.Arrow (second)+import Data.Foldable (Foldable, foldMap)+import Data.List (find)+import qualified Data.Map as M+import Data.Monoid (Sum(..))+import Data.Proxy (Proxy(..))+import qualified Data.Vector.Storable as V+import Data.Vinyl ((:::)(..), PlainRec, Implicit(..), Elem)+import Foreign.Ptr (plusPtr)+import Foreign.Storable+import GHC.TypeLits (Sing, SingI(..), fromSing)+import Graphics.GLUtil hiding (Elem)+import Graphics.Rendering.OpenGL (VertexArrayDescriptor(..), bindBuffer,+ ($=), BufferTarget(..))+import qualified Graphics.Rendering.OpenGL as GL++import Data.Vinyl.Reflect+import Graphics.VinylGL.Uniforms++-- | Representation of a VBO whose type describes the vertices.+newtype BufferedVertices (fields::[*]) = + BufferedVertices { getVertexBuffer :: GL.BufferObject }++-- | Load vertex data into a GPU-accessible buffer.+bufferVertices :: (Storable (PlainRec rs), BufferSource (v (PlainRec rs)))+ => v (PlainRec rs) -> IO (BufferedVertices rs)+bufferVertices = fmap BufferedVertices . fromSource ArrayBuffer++-- | Reload 'BufferedVertices' with a 'V.Vector' of new vertex data.+reloadVertices :: Storable (PlainRec rs)+ => BufferedVertices rs -> V.Vector (PlainRec rs) -> IO ()+reloadVertices b v = do bindBuffer ArrayBuffer $= Just (getVertexBuffer b)+ replaceVector ArrayBuffer v++-- | Delete the object name associated with 'BufferedVertices'.+deleteVertices :: BufferedVertices a -> IO ()+deleteVertices = GL.deleteObjectNames . (:[]) . getVertexBuffer++-- | Bind previously-buffered vertex data.+bindVertices :: BufferedVertices a -> IO ()+bindVertices = (bindBuffer ArrayBuffer $=) . Just . getVertexBuffer++-- | 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 (PlainRec rs)+ => ShaderProgram -> f rs -> IO (Maybe String)+enableVertices s _ = enableAttribs s (Proxy::Proxy (PlainRec 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 (PlainRec rs)+ => ShaderProgram -> f rs -> IO ()+enableVertices' s _ = enableAttribs s (Proxy::Proxy (PlainRec rs)) >>=+ maybe (return ()) error++-- | Produce a 'GL.VertexArrayDescriptor' for a particular field of a+-- vertex record.+fieldToVAD :: forall sy v a r rs. + (r ~ (sy ::: v a), HasFieldNames (PlainRec rs), + HasFieldSizes (PlainRec rs), HasGLType a, Storable (PlainRec rs),+ Num (v a), SingI sy, Foldable v, Implicit (Elem r rs)) =>+ r -> Proxy (PlainRec rs) -> GL.VertexArrayDescriptor a+fieldToVAD _ _ = GL.VertexArrayDescriptor dim+ (glType (undefined::a))+ (fromIntegral $+ sizeOf (undefined::PlainRec rs))+ (offset0 `plusPtr` offset)+ where dim = getSum $ foldMap (const (Sum 1)) (0::v a)+ Just offset = lookup n $ namesAndOffsets (undefined::PlainRec rs)+ n = fromSing (sing::Sing sy)++-- Constraint alias capturing the requirements of a vertex type.+type ViableVertex t = (HasFieldNames t, HasFieldSizes t, HasFieldDims t,+ HasFieldGLTypes t, Storable t)++enableAttribs :: forall v. ViableVertex v+ => ShaderProgram -> Proxy v -> IO (Maybe String)+enableAttribs s p = go (map (second snd) $ M.assocs (attribs s))+ where go [] = return Nothing+ go ((n,t):ns) = case find ((== n) . fieldName) fs of+ Nothing -> return (Just $ "GLSL expecting "++n)+ Just fd+ | fieldType fd == t -> + do enableAttrib s n+ setAttrib s n GL.ToFloat $+ descriptorVAD p fd+ go ns+ | otherwise -> return . Just $+ "Type mismatch in "++n+ fs = fieldDescriptors (undefined::v)++namesAndOffsets :: (HasFieldNames t, HasFieldSizes t) => t -> [(String,Int)]+namesAndOffsets x = zip (fieldNames x) (scanl (+) 0 $ fieldSizes x)++data FieldDescriptor = FieldDescriptor { fieldName :: String+ , fieldOffset :: Int+ , fieldDim :: Int+ , fieldType :: GL.VariableType }+ deriving Show++fieldDescriptors :: ViableVertex t => t -> [FieldDescriptor]+fieldDescriptors x = getZipList $+ FieldDescriptor <$> zl (fieldNames x)+ <*> zl (scanl (+) 0 $ fieldSizes x)+ <*> zl (fieldDims x)+ <*> zl (fieldGLTypes x)+ where zl = ZipList++descriptorVAD :: forall t a. Storable t+ => Proxy t -> FieldDescriptor -> VertexArrayDescriptor a+descriptorVAD _ fd = VertexArrayDescriptor (fromIntegral $ fieldDim fd)+ (variableDataType $ fieldType fd)+ (fromIntegral $+ sizeOf (undefined::t))+ (offset0 `plusPtr` fieldOffset fd)
+ tests/BasicTest.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+import Data.Proxy+import Data.Vinyl+import Data.Word+import Foreign.Ptr (nullPtr, plusPtr)+import Graphics.Rendering.OpenGL (DataType(..), GLfloat,+ VertexArrayDescriptor(..))+import Graphics.VinylGL+import Linear (V1(..), V3(..))+import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import Test.HUnit (Test(..), (~=?))++type Pos = "vpos" ::: V3 GLfloat+type Tag = "tagByte" ::: V1 Word8++tag :: Tag+tag = Field++type Vertex = PlainRec [Pos, Tag]++--testVad :: VertexArrayDescriptor Word8+testVad :: Test+testVad = TestLabel "Sample VAD Creation" $+ vad ~=? fieldToVAD tag (Proxy::Proxy Vertex)+ where vad = VertexArrayDescriptor 1 UnsignedByte 13 (nullPtr `plusPtr` 12)++main :: IO ()+main = defaultMain . hUnitTestToTests $ testVad+++
+ vinyl-gl.cabal view
@@ -0,0 +1,43 @@+name: vinyl-gl+version: 0.1.0.0+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+ library code to reflect over the types of the data to+ facilitate interaction between Haskell and GLSL. See the+ @examples@ directory in the repository for more+ information.+license: BSD3+license-file: LICENSE+author: Anthony Cowley+maintainer: acowley@gmail.com+copyright: Copyright (C) 2013 Anthony Cowley+category: Graphics+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: http://github.com/acowley/vinyl-gl.git++library+ exposed-modules: Data.Vinyl.Reflect, + Graphics.VinylGL, + Graphics.VinylGL.Uniforms, + Graphics.VinylGL.Vertex+ -- other-modules: + build-depends: base >= 4.6 && < 5, transformers >= 0.3, vinyl >= 0.1.3,+ containers >= 0.5, GLUtil >= 0.6.4, OpenGL >= 2.8, + tagged >= 0.4, vector >= 0.10, linear >= 1.1.3+ hs-source-dirs: src+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: BasicTest.hs+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 5,+ test-framework, test-framework-hunit, HUnit,+ linear, vinyl, vinyl-gl, OpenGL, tagged