record-gl (empty) → 0.1.0.0
raw patch · 8 files changed
+626/−0 lines, 8 filesdep +GLUtildep +HUnitdep +OpenGLsetup-changed
Dependencies added: GLUtil, HUnit, OpenGL, base, base-prelude, containers, linear, record, record-gl, tagged, template-haskell, test-framework, test-framework-hunit, vector
Files
- LICENCE +31/−0
- Setup.hs +2/−0
- record-gl.cabal +50/−0
- src/Graphics/RecordGL.hs +7/−0
- src/Graphics/RecordGL/Uniforms.hs +210/−0
- src/Graphics/RecordGL/Vertex.hs +177/−0
- src/Record/Introspection.hs +124/−0
- tests/BasicTests.hs +25/−0
+ LICENCE view
@@ -0,0 +1,31 @@+Original work copyright (c) 2013, Anthony Cowley+Modifications copyright (c) 2015, Sebastián Méndez++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
+ record-gl.cabal view
@@ -0,0 +1,50 @@+name: record-gl+version: 0.1.0.0+synopsis: Utilities for working with OpenGL's GLSL shading language and Nikita Volkov's "Record"s.+description: Using Nikita Volkov's "Record" records+ 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.+license: BSD3+license-file: LICENCE+author: Sebastián Méndez+maintainer: sebas.chinoir@gmail.com+copyright: Original work copyright (C) 2013 Anthony Cowley, modifications copyright (C) 2015 Sebastián Méndez+category: Graphics+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10+source-repository head+ type: git+ location: http://github.com/rabipelais/record-gl++library+ exposed-modules: Graphics.RecordGL+ , Graphics.RecordGL.Vertex+ , Graphics.RecordGL.Uniforms+ , Record.Introspection+--other-modules+-- ghc-options: -ddump-splices+ build-depends: GLUtil >= 0.6.4+ , OpenGL >= 2.8+ , base >=4.6 && <5+ , base-prelude+ , containers >= 0.5+ , linear >= 1.1.3+ , record >= 0.3+ , tagged >= 0.4+ , template-haskell+ , vector >= 0.10+ hs-source-dirs: src+ default-language: Haskell2010++test-suite tests+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ main-is: BasicTests.hs+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 5,+ test-framework, test-framework-hunit, HUnit,+ linear, record, record-gl, OpenGL, tagged
+ src/Graphics/RecordGL.hs view
@@ -0,0 +1,7 @@+-- |++module Graphics.RecordGL ( module Graphics.RecordGL.Vertex+ , module Graphics.RecordGL.Uniforms) where++import Graphics.RecordGL.Uniforms+import Graphics.RecordGL.Vertex
+ src/Graphics/RecordGL/Uniforms.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | 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 'Record' 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.RecordGL.Uniforms (+ -- * Operations for binding uniform values+ setAllUniforms, setSomeUniforms, setUniforms,+ -- * Useful type classes for setting and verifying fields+ HasFieldGLTypes(..), UniformFields, SetUniformFields) where++import BasePrelude hiding (Proxy)+import qualified Data.Map as M+import Graphics.GLUtil (AsUniform (..),+ HasVariableType (..),+ ShaderProgram (..))+import Graphics.Rendering.OpenGL (UniformLocation)+import qualified Graphics.Rendering.OpenGL as GL+import Language.Haskell.TH++import qualified Data.Set as S+import Record.Introspection+import Record.Types++-- | Provide the 'GL.VariableType' of each field in a 'Record'. The list+-- of types has the same order as the fields of the 'Record'.+class HasFieldGLTypes a where+ fieldGLTypes :: a -> [GL.VariableType]++-- | Zips up lists of 'UniformLocation's and a 'Record' setting+-- uniform parameters using the record fields.+class SetUniformFields a where+ setUniformFields :: [Maybe UniformLocation] -> a -> IO ()++type UniformFields a = (HasFieldNames a, HasFieldGLTypes a, SetUniformFields a)++-- | Set GLSL uniform parameters from a 'Record'. 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 record. UniformFields record+ => ShaderProgram -> record -> IO ()+setAllUniforms s r = case checks of+ Left msg -> error msg+ Right _ -> setUniformFields locs r+ where+ fnames = fieldNames r+ checks = do+ namesCheck "record" (M.keys $ uniforms s) fnames+ typesCheck True (snd <$> uniforms s) fieldTypes+ fieldTypes = M.fromList $ zip fnames (fieldGLTypes r)+ locs = map (fmap fst . (`M.lookup` uniforms s)) fnames++-- | Set GLSL uniform parameters form a `Record` representing+-- a subset of all uniform parameters used by a program.+setUniforms :: forall record. UniformFields record => ShaderProgram -> record -> IO ()+setUniforms s r = case checks of+ Left msg -> error msg+ Right _ -> setUniformFields locs r+ where+ fnames = fieldNames r+ checks = do+ namesCheck "GLSL programme" fnames (M.keys $ uniforms s)+ typesCheck False fieldTypes (snd <$> uniforms s)+ fieldTypes = M.fromList $ zip fnames (fieldGLTypes r)+ locs = map (fmap fst . (`M.lookup` uniforms s)) fnames++-- | Set GLSL uniform parameters from those fields of a 'PlainRec'+-- whose names correspond to uniform parameters used by a program.+setSomeUniforms :: forall r. UniformFields r+ => ShaderProgram -> r -> IO ()+setSomeUniforms s r = case typesCheck' True (snd <$> uniforms s) fieldTypes of+ Left msg -> error msg+ Right _ -> setUniformFields locs r+ where+ fnames = fieldNames r+ fieldTypes = M.fromList . zip fnames $ fieldGLTypes r+ locs = map (fmap fst . (`M.lookup` uniforms s)) fnames++-- | @namesCheck culprit little big@ checks that each name in @little@ is+-- an element of @big@.+namesCheck :: String -> [String] -> [String] -> Either String ()+namesCheck culprit little big = mapM_ go little+ where+ big' = S.fromList big+ go x | x `S.member` big' = Right ()+ | otherwise = Left $ "Field " ++ x ++ " not found in " ++ culprit++-- | @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_ go $ M.toList little+ where+ go (n, t) | (glTypeEquiv t <$> M.lookup n big) == Just True = 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 types disagree on field " ++ n +++ ": GLSL expected " ++ expected +++ ", record disappointed with " ++ 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_ go $ M.toList little+ where+ go (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 types disagree on field " ++ n +++ ": GLSL expected " ++ expected +++ ", record disappointed with " ++ actual++-- 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 :: GL.VariableType -> GL.VariableType -> Bool+glTypeEquiv x y = glTypeEquiv' x y || glTypeEquiv' y x++-- 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+++-- Template Haskell instances. Here be dragons, beware... -----------------------++-- I would rather have written this by hand and some Emacs macros...+-- Instances for the HasFieldGLTypes class+-- Example implementation:+-- fieldGLTypes _ = [variableType (undefined::v1),...,variableType (undefined::vn)]+return $ flip map [1..24] $ \arity ->+ let typeName = mkName $ "Record" <> show arity+ recordType = foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))+ (VarT (mkName ("v" <> show i))))+ (ConT typeName)+ [1 .. arity]+ vVals = map (\i -> "v" <> show i) [1..arity]+ vTVals = map (VarT . mkName) vVals+#if MIN_VERSION_template_haskell(2,10,0)+ mkContext c t = AppT (ConT (mkName c)) t+#else+ mkContext c t = ClassP (mkName c) [t]+#endif+ context = map (\v -> mkContext "HasVariableType" v) vTVals+ typesList = ListE $ map (AppE (VarE (mkName "variableType")) .+ SigE (VarE (mkName "undefined")))+ vTVals+ fieldGLTypesFun = FunD (mkName "fieldGLTypes")+ [Clause [WildP] (NormalB typesList) []]+ in InstanceD context+ (AppT (ConT (mkName "HasFieldGLTypes")) recordType)+ [fieldGLTypesFun]++-- Instances for the SetUniformFields class+-- Example implementation:+-- setUniformFields (u1 : ...) (RecordX v1...) = traverse_ (asUniform v1) u1 >> ...+return $ flip map [1..24] $ \arity ->+ let typeName = mkName $ "Record" <> show arity+ recordType = foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))+ (VarT (mkName ("v" <> show i))))+ (ConT typeName)+ [1 .. arity]+ typePattern = ConP typeName (map (\i -> VarP (mkName ("v" <> show i))) [1..arity])+ vNames = map (\i -> mkName $ "v" <> show i) [1..arity]+ vTVals = map VarT vNames+#if MIN_VERSION_template_haskell(2,10,0)+ mkContext c t = AppT (ConT (mkName c)) t+#else+ mkContext c t = ClassP (mkName c) [t]+#endif+ context = map (\v -> mkContext "AsUniform" v) vTVals+ nameE = VarE . mkName+ uniformNames = map (\i -> mkName ("u" <> show i)) [1..arity + 1]+ uniformPat = AsP (mkName "us") $ foldr1 (\i a -> InfixP i (mkName ":") a) $ map VarP uniformNames+ asUniforms = foldr1 (\i a -> InfixE (Just i) (nameE ">>") (Just a)) $ zipWith go us vs+ where+ us = map VarE uniformNames+ go u v = AppE (AppE (nameE "traverse_")+ (AppE (nameE "asUniform") v))+ u+ vs = map VarE vNames+ wrongSizes = NormalG $ InfixE (Just (AppE (nameE "length")+ (nameE "us")))+ (VarE (mkName "<"))+ (Just (LitE (IntegerL arity))) -- I wish this could be done with types+ contrarily = NormalG $ nameE "otherwise"+ setUniformFieldsFun =+ FunD (mkName "setUniformFields")+ [Clause [uniformPat, typePattern]+ (GuardedB [(wrongSizes, AppE (nameE "error")+ (LitE (StringL "Not enough UniformLocations :(")))+ ,(contrarily, asUniforms)]) []]+ in InstanceD context+ (AppT (ConT (mkName "SetUniformFields")) recordType)+ [setUniformFieldsFun]
+ src/Graphics/RecordGL/Vertex.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Utilities for working with vertex buffer objects (VBOs) filled+-- with vertices represented as `Records`.+module Graphics.RecordGL.Vertex (bufferVertices, bindVertices, reloadVertices+ , deleteVertices, enableVertices, enableVertices'+ , enableVertexFields, fieldToVAD+ , ViableVertex, BufferedVertices(..)) where++import Graphics.RecordGL.Uniforms+import Record.Introspection+import Record.Types++import BasePrelude+import qualified Data.Map as M+import Data.Proxy+import qualified Data.Vector.Storable as V+import Foreign.Ptr (plusPtr)+import Foreign.Storable+import GHC.TypeLits+import Graphics.GLUtil hiding (Elem, throwError)+import Graphics.Rendering.OpenGL (BufferTarget (..),+ VertexArrayDescriptor (..),+ bindBuffer, ($=))+import qualified Graphics.Rendering.OpenGL as GL++-- | Representation of a VBO whose type describes the vertices.+data BufferedVertices a =+ BufferedVertices {getVertexBuffer :: GL.BufferObject}++-- | Load vertex data into a GPU-accessible buffer.+bufferVertices :: (Storable rs, BufferSource (v rs)) => v rs -> IO (BufferedVertices rs)+bufferVertices = fmap BufferedVertices . fromSource ArrayBuffer++-- | Reload 'BufferedVertices' with a 'V.Vector' of new vertex data.+reloadVertices :: Storable rs+ => BufferedVertices rs+ -> V.Vector 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++-- | Constraint alias capturing the requirements of a vertex type.+type ViableVertex t = (HasFieldNames t, HasFieldSizes t, HasFieldDims t,+ HasFieldGLTypes t, Storable t)++-- | 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 r. ViableVertex r+ => ShaderProgram -> f r -> IO (Maybe String)+enableVertices s _ = enableAttribs s (Proxy :: Proxy r)++-- | Behaves like 'enableVertices', but raises an exception if the+-- supplied vertex record does not include a field required by the+-- shader.+enableVertices' :: forall f r. ViableVertex r+ => ShaderProgram -> f r -> IO ()+enableVertices' s _ = enableAttribs s (Proxy::Proxy r) >>=+ maybe (return ()) error++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++-- | 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 r. ViableVertex r+ => ShaderProgram -> p r -> IO ()+enableVertexFields s _ = enableSomeAttribs s p >>= maybe (return ()) error+ where+ p = Proxy::Proxy r++-- | Do not raise an error is some of a shader's inputs are not bound+-- by a vertex record.+enableSomeAttribs :: forall v. ViableVertex v+ => ShaderProgram -> Proxy v -> IO (Maybe String)+enableSomeAttribs s p = go $ fieldDescriptors (undefined::v)+ where go [] = return Nothing+ go (fd:fds) =+ let n = fieldName fd+ shaderAttribs = attribs s+ in case M.lookup n shaderAttribs of+ Nothing -> return (Just $ "Unexpected attribute " ++ n)+ Just (_,t)+ | fieldType fd == t -> do enableAttrib s n+ setAttrib s n GL.ToFloat $+ descriptorVAD p fd+ go fds+ | otherwise -> return . Just $ "Type mismatch in " ++ n++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 ((l, t):as) = case find ((== l) . fieldName) fs of+ Nothing -> return (Just $ "GLSL expecting " ++ l)+ Just fd+ | fieldType fd == t -> do+ enableAttrib s l+ setAttrib s l GL.ToFloat $+ descriptorVAD p fd+ go as+ | otherwise -> return . Just $ "Type mismatch in " ++ l+ fs = fieldDescriptors (undefined::v)++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)++namesAndOffsets :: (HasFieldNames t, HasFieldSizes t) => t -> [(String, Int)]+namesAndOffsets x = zip (fieldNames x) (scanl (+) 0 (fieldSizes x))++-- | Produce a 'GL.VertexArrayDescriptor' for a particular field of a+-- vertex record.+-- fieldToVAD :: forall r v a sy proxy.+-- (+-- Foldable v)+-- => String -> proxy r -> GL.VertexArrayDescriptor a+fieldToVAD :: forall sy r v a proxy.+ (Field' sy r (v a), HasFieldNames r, HasFieldSizes r, HasGLType a, Storable r, Num (v a),+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+ KnownSymbol sy,+#else+ SingI sy,+#endif+ Foldable v)+ => FieldName sy -> r -> GL.VertexArrayDescriptor a+fieldToVAD _ _ = GL.VertexArrayDescriptor dim+ (glType (undefined::a))+ (fromIntegral sz)+ (offset0 `plusPtr` offset)+ where+ sz = sizeOf (undefined::r)+ dim = getSum $ foldMap (const (Sum 1)) (0::v a)+ Just offset = lookup n $ namesAndOffsets (undefined::r)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+ n = symbolVal (Proxy::Proxy sy)+#else+ n = fromSing (sing::Sing sy)+#endif
+ src/Record/Introspection.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Introspect field names and other attributes of a "Record".+module Record.Introspection where++import BasePrelude hiding (Proxy)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+import Data.Proxy+#endif+import Foreign.Storable (Storable (sizeOf))+import GHC.TypeLits+import Language.Haskell.TH+import Record.Types++-- | List all field names in a record.+class HasFieldNames a where+ fieldNames :: a -> [String]++return $ flip map [1..24] $ \arity ->+ let typeName = mkName $ "Record" <> show arity+ recordType = foldl (\a i -> AppT (AppT a (SigT (VarT (mkName ("n" <> show i))) (ConT ''Symbol)))+ (VarT (mkName ("v" <> show i))))+ (ConT typeName)+ [1 .. arity]+ nVals = map (\i -> "n" <> show i) [1..arity]+ nTVals = map (VarT . mkName) nVals+#if MIN_VERSION_template_haskell(2,10,0)+ mkContext c t = AppT (ConT (mkName c)) t+#else+ mkContext c t = ClassP (mkName c) [t]+#endif+ fieldNames' = ListE $ flip map nTVals+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+ (\n -> AppE (VarE (mkName "symbolVal"))+ (SigE (ConE (mkName "Proxy")) (AppT (ConT (mkName "Proxy")) n)))+ context = map (\n -> mkContext "KnownSymbol" n) nTVals+#else+ (\n -> AppE (VarE (mkName "fromSing"))+ (SigE (VarE (mkName "sing")) (AppT (ConT (mkName "Sing")) n)))+ context = map (\n -> mkContext "SingI" n) nTVals+#endif+ fieldNamesFun = FunD (mkName "fieldNames")+ [Clause [WildP] (NormalB fieldNames') []]+ in InstanceD context+ (AppT (ConT (mkName "HasFieldNames")) recordType)+ [fieldNamesFun]++-- | 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]++return $ flip map [1..24] $ \arity ->+ let typeName = mkName $ "Record" <> show arity+ recordType = foldl (\a i -> AppT (AppT a (SigT (VarT (mkName ("n" <> show i))) (ConT ''Symbol)))+ (AppT (VarT (mkName ("l" <> show i))) (VarT (mkName ("v" <> show i)))))+ (ConT typeName)+ [1 .. arity]+ vVals = map (\i -> "v" <> show i) [1..arity]+ vTVals = map (VarT . mkName) vVals+ lVals = map (\i -> "l" <> show i) [1..arity]+ lTVals = map (VarT . mkName) lVals+ vectorTVals = zipWith AppT lTVals vTVals+ numCxt = map (\i -> mkContext "Num" i) vectorTVals+ foldCxt = map (\i -> mkContext "Foldable" i) lTVals+ context = foldCxt ++ numCxt+ nameE = VarE . mkName+#if MIN_VERSION_template_haskell(2,10,0)+ mkContext c t = AppT (ConT (mkName c)) t+#else+ mkContext c t = ClassP (mkName c) [t]+#endif+ fieldDims' = ListE $ flip map vectorTVals+ (\v -> nameE "getSum" `AppE`+ (nameE "foldMap" `AppE`+ (nameE "const" `AppE`+ (ConE (mkName "Sum") `AppE` (LitE (IntegerL 1)))) `AppE`+ (SigE (LitE (IntegerL 0)) v)))+ fieldDimsFun = FunD (mkName "fieldDims")+ [Clause [WildP]+ (NormalB fieldDims') []]+ in InstanceD context+ (AppT (ConT (mkName "HasFieldDims")) recordType)+ [fieldDimsFun]++-- | Compute the size in bytes of of each field in a record.+class HasFieldSizes a where+ fieldSizes :: a -> [Int]++return $ flip map [1..24] $ \arity ->+ let typeName = mkName $ "Record" <> show arity+ recordType = foldl (\a i -> AppT (AppT a (SigT (VarT (mkName ("n" <> show i))) (ConT ''Symbol)))+ (VarT (mkName ("v" <> show i))))+ (ConT typeName)+ [1 .. arity]+ vVals = map (\i -> "v" <> show i) [1..arity]+ vTVals = map (VarT . mkName) vVals+#if MIN_VERSION_template_haskell(2,10,0)+ mkContext c t = AppT (ConT (mkName c)) t+#else+ mkContext c t = ClassP (mkName c) [t]+#endif+ context = map (\v -> mkContext "Storable" v) vTVals+ fieldSizes' = ListE $ flip map vTVals+ (\v -> AppE (VarE (mkName "sizeOf"))+ (SigE (VarE (mkName "undefined")) v))+ fieldSizesFun = FunD (mkName "fieldSizes")+ [Clause [WildP] (NormalB fieldSizes') []]+ in InstanceD context+ (AppT (ConT (mkName "HasFieldSizes")) recordType)+ [fieldSizesFun]
+ tests/BasicTests.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}++import Data.Word+import Foreign.Ptr (nullPtr, plusPtr)+import Graphics.RecordGL+import Graphics.Rendering.OpenGL (DataType (..), GLfloat,+ VertexArrayDescriptor (..))+import Linear (V1 (..), V3 (..))+import Record+import Record.Types+import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import Test.HUnit (Test (..), (~=?))++type Vertex = [r| {vpos :: V3 GLfloat, tagByte :: V1 Word8} |]++testVad :: Test+testVad = TestLabel "Sample VAD Creation" $+ vad ~=? fieldToVAD (undefined::FieldName "vpos") (undefined::Vertex)+ where vad = VertexArrayDescriptor 3 Float 13 (nullPtr `plusPtr` 1)++main :: IO ()+main = defaultMain . hUnitTestToTests $ testVad