aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Spear.cabal29
-rw-r--r--Spear.lkshs10
-rw-r--r--Spear.lkshw6
-rw-r--r--Spear/GLSL.hs718
-rw-r--r--Spear/GLSL/Buffer.hs111
-rw-r--r--Spear/GLSL/Error.hs45
-rw-r--r--Spear/GLSL/Management.hs297
-rw-r--r--Spear/GLSL/Texture.hs110
-rw-r--r--Spear/GLSL/Uniform.hs67
-rw-r--r--Spear/GLSL/VAO.hs88
-rw-r--r--Spear/Render/Program.hs2
-rw-r--r--Spear/Render/Texture.hs2
-rw-r--r--Spear/Scene/GameObject.hs3
13 files changed, 730 insertions, 758 deletions
diff --git a/Spear.cabal b/Spear.cabal
index 01a2b23..1f32616 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -21,21 +21,20 @@ library
21 Spear.Assets.Image Spear.Assets.Model Spear.Collision 21 Spear.Assets.Image Spear.Assets.Model Spear.Collision
22 Spear.Math.AABB Spear.Collision.Collision 22 Spear.Math.AABB Spear.Collision.Collision
23 Spear.Collision.Collisioner Spear.Math.Circle Spear.Math.Triangle 23 Spear.Collision.Collisioner Spear.Math.Circle Spear.Math.Triangle
24 Spear.Collision.Types Spear.Game Spear.GLSL Spear.GLSL.Buffer 24 Spear.Collision.Types Spear.Game Spear.GLSL Spear.Math.Camera
25 Spear.GLSL.Error Spear.GLSL.Management Spear.GLSL.Texture 25 Spear.Math.Entity
26 Spear.GLSL.Uniform Spear.GLSL.VAO Spear.Math.Camera 26 Spear.Math.Matrix3 Spear.Math.Matrix4 Spear.Math.MatrixUtils
27 Spear.Math.Entity Spear.Math.Matrix3 Spear.Math.Matrix4 27 Spear.Math.Plane Spear.Math.Quaternion Spear.Math.Vector3
28 Spear.Math.MatrixUtils Spear.Math.Plane Spear.Math.Quaternion 28 Spear.Math.Vector4 Spear.Physics Spear.Physics.Rigid
29 Spear.Math.Vector3 Spear.Math.Vector4 29 Spear.Render.AnimatedModel Spear.Render.Material Spear.Render.Model
30 Spear.Physics Spear.Physics.Rigid Spear.Render.AnimatedModel 30 Spear.Render.Program Spear.Render.Renderable
31 Spear.Render.Material Spear.Render.Model Spear.Render.Program 31 Spear.Render.StaticModel Spear.Render.Texture Spear.Scene.Graph
32 Spear.Render.Renderable Spear.Render.StaticModel 32 Spear.Scene.Light Spear.Scene.Loader Spear.Scene.Scene
33 Spear.Render.Texture Spear.Scene.Graph Spear.Scene.Light 33 Spear.Scene.SceneResources Spear.Setup Spear.Sys.Timer
34 Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources 34 Spear.Sys.Store Spear.Sys.Store.ID Spear.Updatable
35 Spear.Setup Spear.Sys.Timer Spear.Sys.Store Spear.Sys.Store.ID 35 Spear.Math.Vector2 Spear.Math.Quad Spear.Math.Ray
36 Spear.Updatable Spear.Math.Vector2 Spear.Math.Quad Spear.Math.Ray 36 Spear.Math.Segment Spear.Math.Utils Spear.Math.Spatial2
37 Spear.Math.Segment Spear.Math.Utils 37 Spear.Math.Spatial3
38 Spear.Math.Spatial2 Spear.Math.Spatial3
39 exposed: True 38 exposed: True
40 buildable: True 39 buildable: True
41 build-tools: hsc2hs -any 40 build-tools: hsc2hs -any
diff --git a/Spear.lkshs b/Spear.lkshs
index 6eb025a..bc27e60 100644
--- a/Spear.lkshs
+++ b/Spear.lkshs
@@ -1,18 +1,18 @@
1Version of session file format: 1Version of session file format:
2 1 2 1
3Time of storage: 3Time of storage:
4 "Thu Aug 30 17:27:24 CEST 2012" 4 "Thu Aug 30 18:49:02 CEST 2012"
5Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 311) 199)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 705) 954 5Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 6, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 338) 215)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 760) 954
6Population: [(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Factory.hs" 1268)),[SplitP LeftP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Scene/GameObject.hs" 137)),[SplitP LeftP]),(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 328 (PackageScope False,False) (Just (ModuleName ["Game","GameObject"]),Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([[0,1],[0]],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Player.hs" 765)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Utils.hs" 649)),[SplitP LeftP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 5372)),[SplitP LeftP])] 6Population: [(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Factory.hs" 1268)),[SplitP LeftP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/GLSL.hs" 18361)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Scene/GameObject.hs" 137)),[SplitP LeftP]),(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Scene/Loader.hs" 0)),[SplitP LeftP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 328 (PackageScope False,False) (Just (ModuleName ["Spear","GLSL","VAO"]),Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([[0,2],[0]],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Player.hs" 765)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Utils.hs" 835)),[SplitP LeftP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 5372)),[SplitP LeftP])]
7Window size: (1820,939) 7Window size: (1820,939)
8Completion size: 8Completion size:
9 (750,399) 9 (750,399)
10Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" 10Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw"
11Active pane: Just "Factory.hs" 11Active pane: Just "main.hs"
12Toolbar visible: 12Toolbar visible:
13 True 13 True
14FindbarState: (False,FindState {entryStr = "\170", entryHist = ["\170","\\","^","scale","Vector4.","asdad","translv","Vector3.","Vector.","copy_tr","asad","Octree"], replaceStr = "V3.", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) 14FindbarState: (False,FindState {entryStr = "\170", entryHist = ["\170","\\","^","scale","Vector4.","asdad","translv","Vector3.","Vector.","copy_tr","asad","Octree"], replaceStr = "V3.", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = False, regex = False, lineNr = 1})
15Recently opened files: 15Recently opened files:
16 ["/home/jeanne/programming/haskell/Spear/Spear/Render/AnimatedModel.hs","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/OBJ/OBJ_load.c","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/MD2/MD2_load.c","/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject.hs","/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Factory.hs","/home/jeanne/programming/haskell/Spear/Spear/App/Application.hs","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model.hsc","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.c","/home/jeanne/programming/haskell/Spear/Spear/Scene/GameObject.hs","/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameState.hs","/home/jeanne/programming/haskell/Spear/Spear/Render/StaticModel.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Camera.hs"] 16 ["/home/jeanne/programming/haskell/Spear/Spear/GLSL/VAO.hs","/home/jeanne/programming/haskell/Spear/Spear/GLSL/Uniform.hs","/home/jeanne/programming/haskell/Spear/Spear/GLSL/Texture.hs","/home/jeanne/programming/haskell/Spear/Spear/GLSL/Management.hs","/home/jeanne/programming/haskell/Spear/Spear/GLSL/Buffer.hs","/home/jeanne/programming/haskell/Spear/Spear/GLSL/Error.hs","/home/jeanne/programming/haskell/Spear/Spear/Render/AnimatedModel.hs","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/OBJ/OBJ_load.c","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/MD2/MD2_load.c","/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject.hs","/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Factory.hs","/home/jeanne/programming/haskell/Spear/Spear/App/Application.hs"]
17Recently opened workspaces: 17Recently opened workspaces:
18 ["/home/jeanne/programming/haskell/hagen/hagen.lkshw","/home/jeanne/programming/haskell/foo/foo.lkshw","/home/jeanne/programming/haskell/Spear/Spear.lkshw","/home/jeanne/programming/haskell/nexus/nexus.lkshw","/home/jeanne/leksah.lkshw"] \ No newline at end of file 18 ["/home/jeanne/programming/haskell/hagen/hagen.lkshw","/home/jeanne/programming/haskell/foo/foo.lkshw","/home/jeanne/programming/haskell/Spear/Spear.lkshw","/home/jeanne/programming/haskell/nexus/nexus.lkshw","/home/jeanne/leksah.lkshw"] \ No newline at end of file
diff --git a/Spear.lkshw b/Spear.lkshw
index 8163407..656c982 100644
--- a/Spear.lkshw
+++ b/Spear.lkshw
@@ -1,10 +1,10 @@
1Version of workspace file format: 1Version of workspace file format:
2 1 2 1
3Time of storage: 3Time of storage:
4 "Thu Aug 30 16:58:13 CEST 2012" 4 "Thu Aug 30 18:50:08 CEST 2012"
5Name of the workspace: 5Name of the workspace:
6 "Spear" 6 "Spear"
7File paths of contained packages: 7File paths of contained packages:
8 ["demos/simple-scene/simple-scene.cabal","Spear.cabal"] 8 ["Spear.cabal"]
9Maybe file path of an active package: 9Maybe file path of an active package:
10 Just "demos/simple-scene/simple-scene.cabal" \ No newline at end of file 10 Just "Spear.cabal" \ No newline at end of file
diff --git a/Spear/GLSL.hs b/Spear/GLSL.hs
index 4d81a73..e0e1661 100644
--- a/Spear/GLSL.hs
+++ b/Spear/GLSL.hs
@@ -1,20 +1,712 @@
1module Spear.GLSL 1module Spear.GLSL
2( 2(
3 module Spear.GLSL.Buffer 3 -- * General Management
4, module Spear.GLSL.Error 4 GLSLShader
5, module Spear.GLSL.Management 5, GLSLProgram
6, module Spear.GLSL.Texture 6, ShaderType(..)
7, module Spear.GLSL.Uniform 7 -- ** Programs
8, module Spear.GLSL.VAO 8, newProgram
9, module Graphics.Rendering.OpenGL.Raw.Core31 9, releaseProgram
10, linkProgram
11, useProgram
12, withGLSLProgram
13 -- ** Shaders
14, attachShader
15, detachShader
16, loadShader
17, newShader
18, releaseShader
19 -- *** Source loading
20, loadSource
21, shaderSource
22, readSource
23, compile
24 -- ** Locations
25, attribLocation
26, fragLocation
27, uniformLocation
28 -- ** Uniforms
29, uniformVec3
30, uniformVec4
31, uniformMat3
32, uniformMat4
33, uniformfl
34, uniformil
35 -- ** Helper functions
36, ($=)
37, Data.StateVar.get
38
39 -- * VAOs
40, VAO
41 -- ** Creation and destruction
42, newVAO
43, releaseVAO
44 -- ** Manipulation
45, bindVAO
46, enableVAOAttrib
47, attribVAOPointer
48 -- ** Rendering
49, drawArrays
50, drawElements
51
52 -- * Buffers
53, GLBuffer
54, TargetBuffer(..)
55, BufferUsage(..)
56 -- ** Creation and destruction
57, newBuffer
58, releaseBuffer
59 -- ** Manipulation
60, bindBuffer
61, bufferData
62, withGLBuffer
63
64 -- * Textures
65, Texture
66, SettableStateVar
67, GLenum
68, ($)
69 -- ** Creation and destruction
70, newTexture
71, releaseTexture
72 -- ** Manipulation
73, bindTexture
74, loadTextureData
75, texParami
76, texParamf
77, activeTexture
78
79 -- * Error Handling
80, getGLError
81, printGLError
82, assertGL
10) 83)
11where 84where
12 85
13 86
14import Spear.GLSL.Buffer 87import Spear.Math.Matrix3 (Matrix3)
15import Spear.GLSL.Error 88import Spear.Math.Matrix4 (Matrix4)
16import Spear.GLSL.Management 89import Spear.Math.Vector3 as V3
17import Spear.GLSL.Texture 90import Spear.Math.Vector4 as V4
18import Spear.GLSL.Uniform 91import Spear.Setup
19import Spear.GLSL.VAO 92
93import Control.Monad
94import Control.Monad.Trans.Class
95import Control.Monad.Trans.Error
96import Control.Monad.Trans.State as State
97import qualified Data.ByteString.Char8 as B
98import Data.StateVar
99import Foreign.C.String
100import Foreign.Ptr
101import Foreign.Storable
102import Foreign.Marshal.Utils as Foreign (with)
103import Foreign.Marshal.Alloc (alloca)
104import Foreign.Marshal.Array (withArray)
105import Foreign.Storable (peek)
20import Graphics.Rendering.OpenGL.Raw.Core31 106import Graphics.Rendering.OpenGL.Raw.Core31
107import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory)
108import System.IO (hPutStrLn, stderr)
109import Unsafe.Coerce
110
111
112--
113-- MANAGEMENT
114--
115
116
117-- | A GLSL shader handle.
118data GLSLShader = GLSLShader
119 { getShader :: GLuint
120 , getShaderKey :: Resource
121 }
122
123
124-- | A GLSL program handle.
125data GLSLProgram = GLSLProgram
126 { getProgram :: GLuint
127 , getProgramKey :: Resource
128 }
129
130
131-- | Supported shader types.
132data ShaderType = VertexShader | FragmentShader deriving (Eq, Show)
133
134
135toGLShader :: ShaderType -> GLenum
136toGLShader VertexShader = gl_VERTEX_SHADER
137toGLShader FragmentShader = gl_FRAGMENT_SHADER
138
139
140-- | Apply the given function to the program's id.
141withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a
142withGLSLProgram prog f = f $ getProgram prog
143
144
145-- | Get the location of the given uniform variable within the given program.
146uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
147uniformLocation prog var = makeGettableStateVar get
148 where
149 get = withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
150
151
152-- | Get or set the location of the given variable to a fragment shader colour number.
153fragLocation :: GLSLProgram -> String -> StateVar GLint
154fragLocation prog var = makeStateVar get set
155 where
156 get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str)
157 set idx = withCString var $ \str ->
158 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
159
160
161-- | Get or set the location of the given attribute within the given program.
162attribLocation :: GLSLProgram -> String -> StateVar GLint
163attribLocation prog var = makeStateVar get set
164 where
165 get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str)
166 set idx = withCString var $ \str ->
167 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
168
169
170-- | Create a new program.
171newProgram :: [GLSLShader] -> Setup GLSLProgram
172newProgram shaders = do
173 h <- setupIO glCreateProgram
174 when (h == 0) $ setupError "glCreateProgram failed"
175 rkey <- register $ deleteProgram h
176 let program = GLSLProgram h rkey
177
178 mapM_ (setupIO . attachShader program) shaders
179 linkProgram program
180
181 return program
182
183
184-- | Release the program.
185releaseProgram :: GLSLProgram -> Setup ()
186releaseProgram = release . getProgramKey
187
188
189-- | Delete the program.
190deleteProgram :: GLuint -> IO ()
191--deleteProgram = glDeleteProgram
192deleteProgram prog = do
193 putStrLn $ "Deleting shader program " ++ show prog
194 glDeleteProgram prog
195
196
197-- | Link the program.
198linkProgram :: GLSLProgram -> Setup ()
199linkProgram prog = do
200 let h = getProgram prog
201 err <- setupIO $ do
202 glLinkProgram h
203 alloca $ \statptr -> do
204 glGetProgramiv h gl_LINK_STATUS statptr
205 status <- peek statptr
206 case status of
207 0 -> getStatus glGetProgramiv glGetProgramInfoLog h
208 _ -> return ""
209
210 case length err of
211 0 -> return ()
212 _ -> setupError err
213
214
215-- | Use the program.
216useProgram :: GLSLProgram -> IO ()
217useProgram prog = glUseProgram $ getProgram prog
218
219
220-- | Attach the given shader to the given program.
221attachShader :: GLSLProgram -> GLSLShader -> IO ()
222attachShader prog shader = glAttachShader (getProgram prog) (getShader shader)
223
224
225-- | Detach the given GLSL from the given program.
226detachShader :: GLSLProgram -> GLSLShader -> IO ()
227detachShader prog shader = glDetachShader (getProgram prog) (getShader shader)
228
229
230-- | Load a shader from the file specified by the given string.
231--
232-- This function creates a new shader. To load source code into an existing shader,
233-- see 'loadSource', 'shaderSource' and 'readSource'.
234loadShader :: FilePath -> ShaderType -> Setup GLSLShader
235loadShader file shaderType = do
236 shader <- newShader shaderType
237 loadSource file shader
238 compile file shader
239 return shader
240
241
242-- | Create a new shader.
243newShader :: ShaderType -> Setup GLSLShader
244newShader shaderType = do
245 h <- setupIO $ glCreateShader (toGLShader shaderType)
246 case h of
247 0 -> setupError "glCreateShader failed"
248 _ -> do
249 rkey <- register $ deleteShader h
250 return $ GLSLShader h rkey
251
252
253-- | Release the shader.
254releaseShader :: GLSLShader -> Setup ()
255releaseShader = release . getShaderKey
256
257
258-- | Free the shader.
259deleteShader :: GLuint -> IO ()
260--deleteShader = glDeleteShader
261deleteShader shader = do
262 putStrLn $ "Deleting shader " ++ show shader
263 glDeleteShader shader
264
265
266-- | Load a shader source from the file specified by the given string
267-- into the shader.
268loadSource :: FilePath -> GLSLShader -> Setup ()
269loadSource file h = do
270 exists <- setupIO $ doesFileExist file
271 case exists of
272 False -> setupError "the specified shader file does not exist"
273 True -> setupIO $ do
274 code <- readSource file
275 withCString code $ shaderSource h
276
277
278-- | Load the given shader source into the shader.
279shaderSource :: GLSLShader -> CString -> IO ()
280shaderSource shader str =
281 let ptr = unsafeCoerce str
282 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr
283
284
285-- | Compile the shader.
286compile :: FilePath -> GLSLShader -> Setup ()
287compile file shader = do
288 let h = getShader shader
289
290 -- Compile
291 setupIO $ glCompileShader h
292
293 -- Verify status
294 err <- setupIO $ alloca $ \statusPtr -> do
295 glGetShaderiv h gl_COMPILE_STATUS statusPtr
296 result <- peek statusPtr
297 case result of
298 0 -> getStatus glGetShaderiv glGetShaderInfoLog h
299 _ -> return ""
300
301 case length err of
302 0 -> return ()
303 _ -> setupError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
304
305
306type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
307type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
308
309
310getStatus :: StatusCall -> LogCall -> GLuint -> IO String
311getStatus getStatus getLog h = do
312 alloca $ \lenPtr -> do
313 getStatus h gl_INFO_LOG_LENGTH lenPtr
314 len <- peek lenPtr
315 case len of
316 0 -> return ""
317 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len)
318
319
320getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String
321getErrorString getLog h len str = do
322 let ptr = unsafeCoerce str
323 getLog h len nullPtr ptr
324 peekCString str
325
326
327-- | Load the shader source specified by the given file.
328--
329-- This function implements an #include mechanism, so the given file can
330-- refer to other files.
331readSource :: FilePath -> IO String
332readSource = fmap B.unpack . readSource'
333
334
335readSource' :: FilePath -> IO B.ByteString
336readSource' file = do
337 let includeB = B.pack "#include"
338 newLineB = B.pack "\n"
339 isInclude = ((==) includeB) . B.take 8
340 clean = B.dropWhile (\c -> c == ' ')
341 cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ')
342 toLines = B.splitWith (\c -> c == '\n' || c == '\r')
343 addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s
344 parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence .
345 fmap (processLine . clean) . toLines
346 processLine l =
347 if isInclude l
348 then readSource' $ B.unpack . clean . cleanInclude $ l
349 else return l
350
351 contents <- B.readFile file
352
353 dir <- getCurrentDirectory
354 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file
355
356 setCurrentDirectory dir'
357 code <- parse contents
358 setCurrentDirectory dir
359
360 return code
361
362
363-- | Load a 3D vector.
364uniformVec3 :: GLint -> Vector3 -> IO ()
365uniformVec3 loc v = glUniform3f loc x' y' z'
366 where x' = unsafeCoerce $ V3.x v
367 y' = unsafeCoerce $ V3.y v
368 z' = unsafeCoerce $ V3.z v
369
370
371-- | Load a 4D vector.
372uniformVec4 :: GLint -> Vector4 -> IO ()
373uniformVec4 loc v = glUniform4f loc x' y' z' w'
374 where x' = unsafeCoerce $ V4.x v
375 y' = unsafeCoerce $ V4.y v
376 z' = unsafeCoerce $ V4.z v
377 w' = unsafeCoerce $ V4.w v
378
379
380-- | Load a 3x3 matrix.
381uniformMat3 :: GLint -> Matrix3 -> IO ()
382uniformMat3 loc mat =
383 with mat $ \ptrMat ->
384 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
385
386
387-- | Load a 4x4 matrix.
388uniformMat4 :: GLint -> Matrix4 -> IO ()
389uniformMat4 loc mat =
390 with mat $ \ptrMat ->
391 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
392
393
394-- | Load a list of floats.
395uniformfl :: GLint -> [GLfloat] -> IO ()
396uniformfl loc vals = withArray vals $ \ptr ->
397 case length vals of
398 1 -> glUniform1fv loc 1 ptr
399 2 -> glUniform2fv loc 1 ptr
400 3 -> glUniform3fv loc 1 ptr
401 4 -> glUniform4fv loc 1 ptr
402
403
404-- | Load a list of integers.
405uniformil :: GLint -> [GLint] -> IO ()
406uniformil loc vals = withArray vals $ \ptr ->
407 case length vals of
408 1 -> glUniform1iv loc 1 ptr
409 2 -> glUniform2iv loc 1 ptr
410 3 -> glUniform3iv loc 1 ptr
411 4 -> glUniform4iv loc 1 ptr
412
413
414
415
416
417
418--
419-- VAOs
420--
421
422
423-- | A vertex array object.
424data VAO = VAO
425 { getVAO :: GLuint
426 , vaoKey :: Resource
427 }
428
429
430instance Eq VAO where
431 vao1 == vao2 = getVAO vao1 == getVAO vao2
432
433
434instance Ord VAO where
435 vao1 < vao2 = getVAO vao1 < getVAO vao2
436
437
438-- | Create a new vao.
439newVAO :: Setup VAO
440newVAO = do
441 h <- setupIO . alloca $ \ptr -> do
442 glGenVertexArrays 1 ptr
443 peek ptr
444
445 rkey <- register $ deleteVAO h
446 return $ VAO h rkey
447
448
449-- | Release the vao.
450releaseVAO :: VAO -> Setup ()
451releaseVAO = release . vaoKey
452
453
454-- | Delete the vao.
455deleteVAO :: GLuint -> IO ()
456deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1
457
458
459-- | Bind the vao.
460bindVAO :: VAO -> IO ()
461bindVAO = glBindVertexArray . getVAO
462
463
464-- | Enable the given vertex attribute of the bound vao.
465--
466-- See also 'bindVAO'.
467enableVAOAttrib :: GLuint -> IO ()
468enableVAOAttrib = glEnableVertexAttribArray
469
470
471-- | Bind the bound buffer to the given point.
472attribVAOPointer :: GLuint -> GLint -> GLenum -> Bool -> GLsizei -> Int -> IO ()
473attribVAOPointer idx ncomp dattype normalise stride off =
474 glVertexAttribPointer idx ncomp dattype (unsafeCoerce normalise) stride (unsafeCoerce off)
475
476
477-- | Draw the bound vao.
478drawArrays :: GLenum -> Int -> Int -> IO ()
479drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count)
480
481
482-- | Draw the bound vao, indexed mode.
483drawElements :: GLenum -> Int -> GLenum -> Ptr a -> IO ()
484drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
485
486
487
488
489
490
491--
492-- BUFFER
493--
494
495
496-- | An OpenGL buffer.
497data GLBuffer = GLBuffer
498 { getBuffer :: GLuint
499 , rkey :: Resource
500 }
501
502
503-- | The type of target buffer.
504data TargetBuffer
505 = ArrayBuffer
506 | ElementArrayBuffer
507 | PixelPackBuffer
508 | PixelUnpackBuffer
509 deriving (Eq, Show)
510
511
512fromTarget :: TargetBuffer -> GLenum
513fromTarget ArrayBuffer = gl_ARRAY_BUFFER
514fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER
515fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER
516fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER
517
518
519-- | A buffer usage.
520data BufferUsage
521 = StreamDraw
522 | StreamRead
523 | StreamCopy
524 | StaticDraw
525 | StaticRead
526 | StaticCopy
527 | DynamicDraw
528 | DynamicRead
529 | DynamicCopy
530 deriving (Eq, Show)
531
532
533fromUsage :: BufferUsage -> GLenum
534fromUsage StreamDraw = gl_STREAM_DRAW
535fromUsage StreamRead = gl_STREAM_READ
536fromUsage StreamCopy = gl_STREAM_COPY
537fromUsage StaticDraw = gl_STATIC_DRAW
538fromUsage StaticRead = gl_STATIC_READ
539fromUsage StaticCopy = gl_STATIC_COPY
540fromUsage DynamicDraw = gl_DYNAMIC_DRAW
541fromUsage DynamicRead = gl_DYNAMIC_READ
542fromUsage DynamicCopy = gl_DYNAMIC_COPY
543
544
545-- | Create a new buffer.
546newBuffer :: Setup GLBuffer
547newBuffer = do
548 h <- setupIO . alloca $ \ptr -> do
549 glGenBuffers 1 ptr
550 peek ptr
551
552 rkey <- register $ deleteBuffer h
553 return $ GLBuffer h rkey
554
555
556-- | Release the buffer.
557releaseBuffer :: GLBuffer -> Setup ()
558releaseBuffer = release . rkey
559
560
561-- | Delete the buffer.
562deleteBuffer :: GLuint -> IO ()
563deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1
564
565
566-- | Bind the buffer.
567bindBuffer :: GLBuffer -> TargetBuffer -> IO ()
568bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf
569
570
571-- | Set the buffer's data.
572bufferData :: TargetBuffer -> Int -> Ptr a -> BufferUsage -> IO ()
573bufferData target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
574
575
576-- | Apply the given function the buffer's id.
577withGLBuffer :: GLBuffer -> (GLuint -> a) -> a
578withGLBuffer buf f = f $ getBuffer buf
579
580
581
582
583
584
585--
586-- TEXTURE
587--
588
589-- | Represents a texture resource.
590data Texture = Texture
591 { getTex :: GLuint
592 , texKey :: Resource
593 }
594
595
596instance Eq Texture where
597 t1 == t2 = getTex t1 == getTex t2
598
599
600instance Ord Texture where
601 t1 < t2 = getTex t1 < getTex t2
602
603
604-- | Create a new texture.
605newTexture :: Setup Texture
606newTexture = do
607 tex <- setupIO . alloca $ \ptr -> do
608 glGenTextures 1 ptr
609 peek ptr
610
611 rkey <- register $ deleteTexture tex
612 return $ Texture tex rkey
613
614
615-- | Release the texture.
616releaseTexture :: Texture -> Setup ()
617releaseTexture = release . texKey
618
619
620-- | Delete the texture.
621deleteTexture :: GLuint -> IO ()
622--deleteTexture tex = with tex $ glDeleteTextures 1
623deleteTexture tex = do
624 putStrLn $ "Releasing texture " ++ show tex
625 with tex $ glDeleteTextures 1
626
627
628-- | Bind the texture.
629bindTexture :: Texture -> IO ()
630bindTexture = glBindTexture gl_TEXTURE_2D . getTex
631
632
633-- | Load data onto the bound texture.
634--
635-- See also 'bindTexture'.
636loadTextureData :: GLenum
637 -> Int -- ^ Target
638 -> Int -- ^ Level
639 -> Int -- ^ Internal format
640 -> Int -- ^ Width
641 -> Int -- ^ Height
642 -> GLenum -- ^ Border
643 -> GLenum -- ^ Texture type
644 -> Ptr a -- ^ Texture data
645 -> IO ()
646loadTextureData target level internalFormat width height border format texType texData = do
647 glTexImage2D target
648 (fromIntegral level)
649 (fromIntegral internalFormat)
650 (fromIntegral width)
651 (fromIntegral height)
652 (fromIntegral border)
653 (fromIntegral format)
654 texType
655 texData
656
657
658-- | Set the bound texture's parameter to the given value.
659texParami :: GLenum -> GLenum -> SettableStateVar GLenum
660texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val
661
662
663-- | Set the bound texture's parameter to the given value.
664texParamf :: GLenum -> GLenum -> SettableStateVar Float
665texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val)
666
667
668-- | Set the active texture unit.
669activeTexture :: SettableStateVar GLenum
670activeTexture = makeSettableStateVar glActiveTexture
671
672
673
674
675
676
677--
678-- ERROR
679--
680
681
682-- | Get the last OpenGL error.
683getGLError :: IO (Maybe String)
684getGLError = fmap translate glGetError
685 where
686 translate err
687 | err == gl_NO_ERROR = Nothing
688 | err == gl_INVALID_ENUM = Just "Invalid enum"
689 | err == gl_INVALID_VALUE = Just "Invalid value"
690 | err == gl_INVALID_OPERATION = Just "Invalid operation"
691 | err == gl_OUT_OF_MEMORY = Just "Out of memory"
692 | otherwise = Just "Unknown error"
693
694
695-- | Print the last OpenGL error.
696printGLError :: IO ()
697printGLError = getGLError >>= \err -> case err of
698 Nothing -> return ()
699 Just str -> hPutStrLn stderr str
700
701
702-- | Run the given setup action and check for OpenGL errors.
703--
704-- If an OpenGL error is produced, an exception is thrown containing
705-- the given string appended to the string describing the error.
706assertGL :: Setup a -> String -> Setup a
707assertGL action err = do
708 result <- action
709 status <- setupIO getGLError
710 case status of
711 Just str -> setupError $ "OpenGL error raised: " ++ err ++ "; " ++ str
712 Nothing -> return result
diff --git a/Spear/GLSL/Buffer.hs b/Spear/GLSL/Buffer.hs
deleted file mode 100644
index 0f43d66..0000000
--- a/Spear/GLSL/Buffer.hs
+++ /dev/null
@@ -1,111 +0,0 @@
1module Spear.GLSL.Buffer
2(
3 GLBuffer
4, TargetBuffer(..)
5, BufferUsage(..)
6, newBuffer
7, releaseBuffer
8, bindBuffer
9, bufferData
10, withGLBuffer
11)
12where
13
14
15import Spear.Setup
16import Spear.GLSL.Management
17
18import Graphics.Rendering.OpenGL.Raw.Core31
19import Control.Monad.Trans.Class (lift)
20import Data.StateVar
21import Foreign.Ptr
22import Foreign.Marshal.Utils as Foreign (with)
23import Foreign.Marshal.Alloc (alloca)
24import Foreign.Storable (peek)
25import Unsafe.Coerce
26
27
28-- | Represents an OpenGL buffer.
29data GLBuffer = GLBuffer
30 { getBuffer :: GLuint
31 , rkey :: Resource
32 }
33
34
35-- | Represents a target buffer.
36data TargetBuffer
37 = ArrayBuffer
38 | ElementArrayBuffer
39 | PixelPackBuffer
40 | PixelUnpackBuffer
41 deriving (Eq, Show)
42
43
44fromTarget :: TargetBuffer -> GLenum
45fromTarget ArrayBuffer = gl_ARRAY_BUFFER
46fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER
47fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER
48fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER
49
50
51-- | Represents a type of buffer usage.
52data BufferUsage
53 = StreamDraw
54 | StreamRead
55 | StreamCopy
56 | StaticDraw
57 | StaticRead
58 | StaticCopy
59 | DynamicDraw
60 | DynamicRead
61 | DynamicCopy
62 deriving (Eq, Show)
63
64
65fromUsage :: BufferUsage -> GLenum
66fromUsage StreamDraw = gl_STREAM_DRAW
67fromUsage StreamRead = gl_STREAM_READ
68fromUsage StreamCopy = gl_STREAM_COPY
69fromUsage StaticDraw = gl_STATIC_DRAW
70fromUsage StaticRead = gl_STATIC_READ
71fromUsage StaticCopy = gl_STATIC_COPY
72fromUsage DynamicDraw = gl_DYNAMIC_DRAW
73fromUsage DynamicRead = gl_DYNAMIC_READ
74fromUsage DynamicCopy = gl_DYNAMIC_COPY
75
76
77-- | Create a 'GLBuffer'.
78newBuffer :: Setup GLBuffer
79newBuffer = do
80 h <- setupIO . alloca $ \ptr -> do
81 glGenBuffers 1 ptr
82 peek ptr
83
84 rkey <- register $ deleteBuffer h
85 return $ GLBuffer h rkey
86
87
88-- | Release the given 'GLBuffer'.
89releaseBuffer :: GLBuffer -> Setup ()
90releaseBuffer = release . rkey
91
92
93-- | Delete the given 'GLBuffer'.
94deleteBuffer :: GLuint -> IO ()
95deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1
96
97
98-- | Bind the given 'GLBuffer'.
99bindBuffer :: GLBuffer -> TargetBuffer -> IO ()
100bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf
101
102
103-- | Set buffer data.
104bufferData :: TargetBuffer -> Int -> Ptr a -> BufferUsage -> IO ()
105bufferData target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
106
107
108-- | Apply the given function the 'GLBuffer''s id.
109withGLBuffer :: GLBuffer -> (GLuint -> a) -> a
110withGLBuffer buf f = f $ getBuffer buf
111
diff --git a/Spear/GLSL/Error.hs b/Spear/GLSL/Error.hs
deleted file mode 100644
index 7865996..0000000
--- a/Spear/GLSL/Error.hs
+++ /dev/null
@@ -1,45 +0,0 @@
1module Spear.GLSL.Error
2(
3 getGLError
4, printGLError
5, assertGL
6)
7where
8
9
10import Spear.Setup
11
12import Graphics.Rendering.OpenGL.Raw.Core31
13import System.IO (hPutStrLn, stderr)
14
15
16-- | Get the last OpenGL error.
17getGLError :: IO (Maybe String)
18getGLError = fmap translate glGetError
19 where
20 translate err
21 | err == gl_NO_ERROR = Nothing
22 | err == gl_INVALID_ENUM = Just "Invalid enum"
23 | err == gl_INVALID_VALUE = Just "Invalid value"
24 | err == gl_INVALID_OPERATION = Just "Invalid operation"
25 | err == gl_OUT_OF_MEMORY = Just "Out of memory"
26 | otherwise = Just "Unknown error"
27
28
29-- | Print the last OpenGL error.
30printGLError :: IO ()
31printGLError = getGLError >>= \err -> case err of
32 Nothing -> return ()
33 Just str -> hPutStrLn stderr str
34
35
36-- | Run the given 'Setup' action and check for OpenGL errors.
37-- If an OpenGL error is produced, an exception is thrown
38-- containing the given string and the OpenGL error.
39assertGL :: Setup a -> String -> Setup a
40assertGL action err = do
41 result <- action
42 status <- setupIO getGLError
43 case status of
44 Just str -> setupError $ "OpenGL error raised: " ++ err ++ "; " ++ str
45 Nothing -> return result
diff --git a/Spear/GLSL/Management.hs b/Spear/GLSL/Management.hs
deleted file mode 100644
index 81cf45f..0000000
--- a/Spear/GLSL/Management.hs
+++ /dev/null
@@ -1,297 +0,0 @@
1module Spear.GLSL.Management
2(
3 -- * Data types
4 GLSLShader
5, GLSLProgram
6, ShaderType(..)
7 -- * Program manipulation
8, newProgram
9, releaseProgram
10, linkProgram
11, useProgram
12, withGLSLProgram
13 -- * Shader manipulation
14, attachShader
15, detachShader
16, loadShader
17, newShader
18, releaseShader
19 -- ** Source loading
20, loadSource
21, shaderSource
22, readSource
23, compile
24 -- * Location
25, attribLocation
26, fragLocation
27, uniformLocation
28 -- * Helper functions
29, ($=)
30, Data.StateVar.get
31)
32where
33
34
35import Spear.Setup
36
37import Control.Monad ((<=<), forM)
38import Control.Monad.Trans.State as State
39import Control.Monad.Trans.Error
40import Control.Monad.Trans.Class
41import Control.Monad (mapM_, when)
42import qualified Data.ByteString.Char8 as B
43import Data.StateVar
44import Foreign.Ptr
45import Foreign.Storable
46import Foreign.C.String
47import Foreign.Marshal.Alloc (alloca)
48import Foreign.Marshal.Array (withArray)
49import Graphics.Rendering.OpenGL.Raw.Core31
50import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory)
51import Unsafe.Coerce
52
53
54-- | Represents a GLSL shader handle.
55data GLSLShader = GLSLShader
56 { getShader :: GLuint
57 , getShaderKey :: Resource
58 }
59
60
61-- | Represents a GLSL program handle.
62data GLSLProgram = GLSLProgram
63 { getProgram :: GLuint
64 , getProgramKey :: Resource
65 }
66
67
68-- | Encodes several shader types.
69data ShaderType = VertexShader | FragmentShader deriving (Eq, Show)
70
71
72toGLShader :: ShaderType -> GLenum
73toGLShader VertexShader = gl_VERTEX_SHADER
74toGLShader FragmentShader = gl_FRAGMENT_SHADER
75
76
77-- | Apply the given function to the GLSLProgram's id.
78withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a
79withGLSLProgram prog f = f $ getProgram prog
80
81
82-- | Get the location of the given uniform variable within the given program.
83uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
84uniformLocation prog var = makeGettableStateVar get
85 where
86 get = withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
87
88
89-- | Get or set the location of the given variable to a fragment shader colour number.
90fragLocation :: GLSLProgram -> String -> StateVar GLint
91fragLocation prog var = makeStateVar get set
92 where
93 get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str)
94 set idx = withCString var $ \str ->
95 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
96
97
98-- | Get or set the location of the given attribute within the given program.
99attribLocation :: GLSLProgram -> String -> StateVar GLint
100attribLocation prog var = makeStateVar get set
101 where
102 get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str)
103 set idx = withCString var $ \str ->
104 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
105
106
107-- | Create a 'GLSLProgram'.
108newProgram :: [GLSLShader] -> Setup GLSLProgram
109newProgram shaders = do
110 h <- setupIO glCreateProgram
111 when (h == 0) $ setupError "glCreateProgram failed"
112 rkey <- register $ deleteProgram h
113 let program = GLSLProgram h rkey
114
115 mapM_ (setupIO . attachShader program) shaders
116 linkProgram program
117
118 return program
119
120
121-- | Release the given 'GLSLProgram'.
122releaseProgram :: GLSLProgram -> Setup ()
123releaseProgram = release . getProgramKey
124
125
126-- | Delete the given 'GLSLProgram'.
127deleteProgram :: GLuint -> IO ()
128--deleteProgram = glDeleteProgram
129deleteProgram prog = do
130 putStrLn $ "Deleting shader program " ++ show prog
131 glDeleteProgram prog
132
133
134-- | Link the given GLSL program.
135linkProgram :: GLSLProgram -> Setup ()
136linkProgram prog = do
137 let h = getProgram prog
138 err <- setupIO $ do
139 glLinkProgram h
140 alloca $ \statptr -> do
141 glGetProgramiv h gl_LINK_STATUS statptr
142 status <- peek statptr
143 case status of
144 0 -> getStatus glGetProgramiv glGetProgramInfoLog h
145 _ -> return ""
146
147 case length err of
148 0 -> return ()
149 _ -> setupError err
150
151
152-- | Use the given GLSL program.
153useProgram :: GLSLProgram -> IO ()
154useProgram prog = glUseProgram $ getProgram prog
155
156
157-- | Attach the given GLSL shader to the given GLSL program.
158attachShader :: GLSLProgram -> GLSLShader -> IO ()
159attachShader prog shader = glAttachShader (getProgram prog) (getShader shader)
160
161
162-- | Detach the given GLSL shader from the given GLSL program.
163detachShader :: GLSLProgram -> GLSLShader -> IO ()
164detachShader prog shader = glDetachShader (getProgram prog) (getShader shader)
165
166
167-- | Load a shader from the file specified by the given string.
168--
169-- This function creates a new shader. To load source code into an existing shader,
170-- see 'loadSource', 'shaderSource' and 'readSource'.
171loadShader :: FilePath -> ShaderType -> Setup GLSLShader
172loadShader file shaderType = do
173 shader <- newShader shaderType
174 loadSource file shader
175 compile file shader
176 return shader
177
178
179-- | Create a new shader.
180newShader :: ShaderType -> Setup GLSLShader
181newShader shaderType = do
182 h <- setupIO $ glCreateShader (toGLShader shaderType)
183 case h of
184 0 -> setupError "glCreateShader failed"
185 _ -> do
186 rkey <- register $ deleteShader h
187 return $ GLSLShader h rkey
188
189
190-- | Release the given 'GLSLShader'.
191releaseShader :: GLSLShader -> Setup ()
192releaseShader = release . getShaderKey
193
194
195-- | Free the given shader.
196deleteShader :: GLuint -> IO ()
197--deleteShader = glDeleteShader
198deleteShader shader = do
199 putStrLn $ "Deleting shader " ++ show shader
200 glDeleteShader shader
201
202
203-- | Load a shader source from the file specified by the given string into the given shader.
204loadSource :: FilePath -> GLSLShader -> Setup ()
205loadSource file h = do
206 exists <- setupIO $ doesFileExist file
207 case exists of
208 False -> setupError "the specified shader file does not exist"
209 True -> setupIO $ do
210 code <- readSource file
211 withCString code $ shaderSource h
212
213
214-- | Load the given shader source into the given shader.
215shaderSource :: GLSLShader -> CString -> IO ()
216shaderSource shader str =
217 let ptr = unsafeCoerce str
218 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr
219
220
221-- | Compile the given shader.
222compile :: FilePath -> GLSLShader -> Setup ()
223compile file shader = do
224 let h = getShader shader
225
226 -- Compile
227 setupIO $ glCompileShader h
228
229 -- Verify status
230 err <- setupIO $ alloca $ \statusPtr -> do
231 glGetShaderiv h gl_COMPILE_STATUS statusPtr
232 result <- peek statusPtr
233 case result of
234 0 -> getStatus glGetShaderiv glGetShaderInfoLog h
235 _ -> return ""
236
237 case length err of
238 0 -> return ()
239 _ -> setupError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
240
241
242type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
243type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
244
245
246getStatus :: StatusCall -> LogCall -> GLuint -> IO String
247getStatus getStatus getLog h = do
248 alloca $ \lenPtr -> do
249 getStatus h gl_INFO_LOG_LENGTH lenPtr
250 len <- peek lenPtr
251 case len of
252 0 -> return ""
253 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len)
254
255
256getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String
257getErrorString getLog h len str = do
258 let ptr = unsafeCoerce str
259 getLog h len nullPtr ptr
260 peekCString str
261
262
263-- | Load the shader source specified by the given file.
264--
265-- This function implements an #include mechanism, so the given file can
266-- refer to other files.
267readSource :: FilePath -> IO String
268readSource = fmap B.unpack . readSource'
269
270
271readSource' :: FilePath -> IO B.ByteString
272readSource' file = do
273 let includeB = B.pack "#include"
274 newLineB = B.pack "\n"
275 isInclude = ((==) includeB) . B.take 8
276 clean = B.dropWhile (\c -> c == ' ')
277 cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ')
278 toLines = B.splitWith (\c -> c == '\n' || c == '\r')
279 addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s
280 parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence .
281 fmap (processLine . clean) . toLines
282 processLine l =
283 if isInclude l
284 then readSource' $ B.unpack . clean . cleanInclude $ l
285 else return l
286
287 contents <- B.readFile file
288
289 dir <- getCurrentDirectory
290 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file
291
292 setCurrentDirectory dir'
293 code <- parse contents
294 setCurrentDirectory dir
295
296 return code
297
diff --git a/Spear/GLSL/Texture.hs b/Spear/GLSL/Texture.hs
deleted file mode 100644
index 8d361a1..0000000
--- a/Spear/GLSL/Texture.hs
+++ /dev/null
@@ -1,110 +0,0 @@
1module Spear.GLSL.Texture
2(
3 Texture
4, SettableStateVar
5, GLenum
6, ($)
7 -- * Creation and destruction
8, newTexture
9, releaseTexture
10 -- * Manipulation
11, bindTexture
12, loadTextureData
13, texParami
14, texParamf
15, activeTexture
16)
17where
18
19
20import Spear.Setup
21
22import Data.StateVar
23import Foreign.Marshal.Alloc (alloca)
24import Foreign.Marshal.Utils (with)
25import Foreign.Ptr
26import Foreign.Storable (peek)
27import Graphics.Rendering.OpenGL.Raw.Core31
28import Unsafe.Coerce (unsafeCoerce)
29
30
31-- | Represents a texture resource.
32data Texture = Texture
33 { getTex :: GLuint
34 , rkey :: Resource
35 }
36
37
38instance Eq Texture where
39 t1 == t2 = getTex t1 == getTex t2
40
41
42instance Ord Texture where
43 t1 < t2 = getTex t1 < getTex t2
44
45
46-- | Create a new 'Texture'.
47newTexture :: Setup Texture
48newTexture = do
49 tex <- setupIO . alloca $ \ptr -> do
50 glGenTextures 1 ptr
51 peek ptr
52
53 rkey <- register $ deleteTexture tex
54 return $ Texture tex rkey
55
56
57-- | Release the given 'Texture'.
58releaseTexture :: Texture -> Setup ()
59releaseTexture = release . rkey
60
61
62-- | Delete the given 'Texture'.
63deleteTexture :: GLuint -> IO ()
64--deleteTexture tex = with tex $ glDeleteTextures 1
65deleteTexture tex = do
66 putStrLn $ "Releasing texture " ++ show tex
67 with tex $ glDeleteTextures 1
68
69
70-- | Bind the given 'Texture'.
71bindTexture :: Texture -> IO ()
72bindTexture = glBindTexture gl_TEXTURE_2D . getTex
73
74
75-- | Load data onto the bound 'Texture'.
76loadTextureData :: GLenum
77 -> Int -- ^ Target
78 -> Int -- ^ Level
79 -> Int -- ^ Internal format
80 -> Int -- ^ Width
81 -> Int -- ^ Height
82 -> GLenum -- ^ Border
83 -> GLenum -- ^ Texture type
84 -> Ptr a -- ^ Texture data
85 -> IO ()
86loadTextureData target level internalFormat width height border format texType texData = do
87 glTexImage2D target
88 (fromIntegral level)
89 (fromIntegral internalFormat)
90 (fromIntegral width)
91 (fromIntegral height)
92 (fromIntegral border)
93 (fromIntegral format)
94 texType
95 texData
96
97
98-- | Set the bound texture's given parameter to the given value.
99texParami :: GLenum -> GLenum -> SettableStateVar GLenum
100texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val
101
102
103-- | Set the bound texture's given parameter to the given value.
104texParamf :: GLenum -> GLenum -> SettableStateVar Float
105texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val)
106
107
108-- | Set the active texture unit.
109activeTexture :: SettableStateVar GLenum
110activeTexture = makeSettableStateVar glActiveTexture
diff --git a/Spear/GLSL/Uniform.hs b/Spear/GLSL/Uniform.hs
deleted file mode 100644
index f186333..0000000
--- a/Spear/GLSL/Uniform.hs
+++ /dev/null
@@ -1,67 +0,0 @@
1module Spear.GLSL.Uniform
2(
3 uniformVec3
4, uniformVec4
5, uniformMat3
6, uniformMat4
7, uniformfl
8, uniformil
9)
10where
11
12
13import Spear.GLSL.Management
14import Spear.Math.Matrix3 (Matrix3)
15import Spear.Math.Matrix4 (Matrix4)
16import Spear.Math.Vector3 as V3
17import Spear.Math.Vector4 as V4
18
19import Foreign.Marshal.Array (withArray)
20import Foreign.Marshal.Utils
21import Graphics.Rendering.OpenGL.Raw.Core31
22import Unsafe.Coerce
23
24
25uniformVec3 :: GLint -> Vector3 -> IO ()
26uniformVec3 loc v = glUniform3f loc x' y' z'
27 where x' = unsafeCoerce $ V3.x v
28 y' = unsafeCoerce $ V3.y v
29 z' = unsafeCoerce $ V3.z v
30
31
32uniformVec4 :: GLint -> Vector4 -> IO ()
33uniformVec4 loc v = glUniform4f loc x' y' z' w'
34 where x' = unsafeCoerce $ V4.x v
35 y' = unsafeCoerce $ V4.y v
36 z' = unsafeCoerce $ V4.z v
37 w' = unsafeCoerce $ V4.w v
38
39
40uniformMat3 :: GLint -> Matrix3 -> IO ()
41uniformMat3 loc mat =
42 with mat $ \ptrMat ->
43 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
44
45
46uniformMat4 :: GLint -> Matrix4 -> IO ()
47uniformMat4 loc mat =
48 with mat $ \ptrMat ->
49 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
50
51
52uniformfl :: GLint -> [GLfloat] -> IO ()
53uniformfl loc vals = withArray vals $ \ptr ->
54 case length vals of
55 1 -> glUniform1fv loc 1 ptr
56 2 -> glUniform2fv loc 1 ptr
57 3 -> glUniform3fv loc 1 ptr
58 4 -> glUniform4fv loc 1 ptr
59
60
61uniformil :: GLint -> [GLint] -> IO ()
62uniformil loc vals = withArray vals $ \ptr ->
63 case length vals of
64 1 -> glUniform1iv loc 1 ptr
65 2 -> glUniform2iv loc 1 ptr
66 3 -> glUniform3iv loc 1 ptr
67 4 -> glUniform4iv loc 1 ptr
diff --git a/Spear/GLSL/VAO.hs b/Spear/GLSL/VAO.hs
deleted file mode 100644
index f121636..0000000
--- a/Spear/GLSL/VAO.hs
+++ /dev/null
@@ -1,88 +0,0 @@
1module Spear.GLSL.VAO
2(
3 VAO
4 -- * Creation and destruction
5, newVAO
6, releaseVAO
7 -- * Manipulation
8, bindVAO
9, enableVAOAttrib
10, attribVAOPointer
11 -- * Rendering
12, drawArrays
13, drawElements
14)
15where
16
17
18import Spear.Setup
19import Control.Monad.Trans.Class (lift)
20import Foreign.Marshal.Utils as Foreign (with)
21import Foreign.Marshal.Alloc (alloca)
22import Foreign.Storable (peek)
23import Foreign.Ptr
24import Unsafe.Coerce
25import Graphics.Rendering.OpenGL.Raw.Core31
26
27
28-- | Represents a vertex array object.
29data VAO = VAO
30 { getVAO :: GLuint
31 , rkey :: Resource
32 }
33
34
35instance Eq VAO where
36 vao1 == vao2 = getVAO vao1 == getVAO vao2
37
38
39instance Ord VAO where
40 vao1 < vao2 = getVAO vao1 < getVAO vao2
41
42
43-- | Create a new 'VAO'.
44newVAO :: Setup VAO
45newVAO = do
46 h <- setupIO . alloca $ \ptr -> do
47 glGenVertexArrays 1 ptr
48 peek ptr
49
50 rkey <- register $ deleteVAO h
51 return $ VAO h rkey
52
53
54-- | Release the given 'VAO'.
55releaseVAO :: VAO -> Setup ()
56releaseVAO = release . rkey
57
58
59-- | Delete the given 'VAO'.
60deleteVAO :: GLuint -> IO ()
61deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1
62
63
64-- | Bind the given 'VAO'.
65bindVAO :: VAO -> IO ()
66bindVAO = glBindVertexArray . getVAO
67
68
69-- | Enable the given vertex attribute of the bound 'VAO'.
70enableVAOAttrib :: GLuint -> IO ()
71enableVAOAttrib = glEnableVertexAttribArray
72
73
74-- | Bind the bound buffer to the given point.
75attribVAOPointer :: GLuint -> GLint -> GLenum -> Bool -> GLsizei -> Int -> IO ()
76attribVAOPointer idx ncomp dattype normalise stride off =
77 glVertexAttribPointer idx ncomp dattype (unsafeCoerce normalise) stride (unsafeCoerce off)
78
79
80-- | Draw the bound 'VAO'.
81drawArrays :: GLenum -> Int -> Int -> IO ()
82drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count)
83
84
85-- | Draw the bound 'VAO', indexed mode.
86drawElements :: GLenum -> Int -> GLenum -> Ptr a -> IO ()
87drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
88
diff --git a/Spear/Render/Program.hs b/Spear/Render/Program.hs
index 9755aa3..ab2a548 100644
--- a/Spear/Render/Program.hs
+++ b/Spear/Render/Program.hs
@@ -12,7 +12,7 @@ module Spear.Render.Program
12where 12where
13 13
14 14
15import Spear.GLSL.Management (GLSLProgram) 15import Spear.GLSL (GLSLProgram)
16 16
17 17
18import Graphics.Rendering.OpenGL.Raw.Core31 18import Graphics.Rendering.OpenGL.Raw.Core31
diff --git a/Spear/Render/Texture.hs b/Spear/Render/Texture.hs
index 59e7797..3311ce6 100644
--- a/Spear/Render/Texture.hs
+++ b/Spear/Render/Texture.hs
@@ -7,7 +7,7 @@ where
7 7
8import Spear.Setup 8import Spear.Setup
9import Spear.Assets.Image 9import Spear.Assets.Image
10import Spear.GLSL.Texture 10import Spear.GLSL
11import Data.StateVar (($=)) 11import Data.StateVar (($=))
12import Graphics.Rendering.OpenGL.Raw.Core31 12import Graphics.Rendering.OpenGL.Raw.Core31
13 13
diff --git a/Spear/Scene/GameObject.hs b/Spear/Scene/GameObject.hs
index 89db341..cfc825d 100644
--- a/Spear/Scene/GameObject.hs
+++ b/Spear/Scene/GameObject.hs
@@ -25,8 +25,7 @@ where
25 25
26import Spear.Collision.Collision 26import Spear.Collision.Collision
27import Spear.Collision.Collisioner as Col 27import Spear.Collision.Collisioner as Col
28import Spear.GLSL.Management 28import Spear.GLSL
29import Spear.GLSL.Uniform
30import Spear.Math.AABB 29import Spear.Math.AABB
31import qualified Spear.Math.Camera as Cam 30import qualified Spear.Math.Camera as Cam
32import qualified Spear.Math.Matrix3 as M3 31import qualified Spear.Math.Matrix3 as M3
generated by cgit v1.2.3 (git 2.25.1) at 2025-11-02 13:21:15 +0000