throw out more of GLUtil

app/Types.hs

@@ -4,3 +4,4 @@ module Types
 
 import Types.UserData as T
 import Types.Sprite as T
+import Types.CanvasShader as T

app/Types/CanvasShader.hs

@@ -0,0 +1,26 @@
+module Types.CanvasShader where
+
+import Data.List as L
+
+import Data.Map.Strict
+
+import Graphics.Rendering.OpenGL (get)
+import qualified Graphics.Rendering.OpenGL as GL
+
+data CanvasShader = CanvasShader
+  { shaderAttribs :: Map String (GL.AttribLocation, GL.VariableType)
+  , shaderUniforms :: Map String (GL.UniformLocation, GL.VariableType)
+  , shaderProgram :: GL.Program
+  }
+
+makeCanvasShader :: GL.Program -> IO CanvasShader
+makeCanvasShader p = CanvasShader
+  <$> (fromList <$> ((get (GL.activeAttribs p) >>= mapM (aux (GL.attribLocation p)))))
+  <*> (fromList <$> ((get (GL.activeUniforms p)
+       >>= mapM (aux (GL.uniformLocation p) . on3 trimArray))))
+  <*> (pure p)
+  where aux f (_,t,name) = get (f name) >>= \l -> return (name, (l, t))
+        on3 f (a,b,c) = (a, b, f c)
+        -- An array uniform, foo, is sometimes given the name "foo" and
+        -- sometimes the name "foo[0]". We strip off the "[0]" if present.
+        trimArray n = if "[0]" `isSuffixOf` n then L.take (length n - 3) n else n

app/Types/Sprite.hs

@@ -1,18 +1,29 @@
 {-# LANGUAGE TypeFamilies #-}
 module Types.Sprite where
 
+import Data.Maybe (maybe)
+import qualified Data.Map.Strict as M
+
 import SDL (get, ($=))
 
 import qualified Graphics.Rendering.OpenGL as GL
-import qualified Graphics.GLUtil as GLU
+import qualified Graphics.GL.Core33 as GLRaw
+-- import qualified Graphics.GLUtil as GLU
 
 import Codec.Picture
 
 import Linear
 
+import Foreign.Ptr
+
+import Foreign.Marshal.Utils (with)
+
+import Unsafe.Coerce (unsafeCoerce)
+
 -- internal imports
 
 import Classes.Renderable
+import Types.CanvasShader
 
 data SpriteRenderObjects = SpriteRenderObjects
   { roVAO :: GL.VertexArrayObject
@@ -20,7 +31,7 @@ data SpriteRenderObjects = SpriteRenderObjects
   }
 
 data SpriteShaderObjects = SpriteShaderObjects
-  { soProgram        :: GLU.ShaderProgram
+  { soProgram        :: CanvasShader
   }
 
 data Sprite = Sprite
@@ -35,10 +46,10 @@ instance Renderable Sprite where
 
   init
     (SpriteRenderObjects vao vbo)
-    (SpriteShaderObjects prog)
+    (SpriteShaderObjects (CanvasShader att uni prog))
     texture
     _ = do
-      GL.currentProgram $= Just (GLU.program prog)
+      GL.currentProgram $= Just prog
       GL.bindVertexArrayObject $= Just vao
       GL.activeTexture $= GL.TextureUnit 0
       GL.textureBinding GL.Texture2D $= Just texture
@@ -47,7 +58,7 @@ instance Renderable Sprite where
 
   draw
     (SpriteRenderObjects vao vbo)
-    (SpriteShaderObjects prog)
+    (SpriteShaderObjects (CanvasShader att uni prog))
     (Sprite pos@(V2 px py) size) = do
       let (V2 sx sy) = fmap fromIntegral size
           model = fmap (fmap fromIntegral) $ V4
@@ -58,8 +69,15 @@ instance Renderable Sprite where
             :: M44 Float
           projection = ortho (-960) 960 (-540) 540 (-1) 1
       -- putStrLn $ show model
-      GLU.setUniform prog "pm" (projection !*! model)
+      maybe
+        (const (putStrLn warn >> return ()))
+        (flip asUniform . fst)
+        (M.lookup "pm" uni)
+        (projection !*! model)
       GL.drawArrays GL.Triangles 0 6
+      where
+        warn = "WARNING: uniform pm is not active"
+        v `asUniform` loc = with v $ GLRaw.glUniformMatrix4fv (unsafeCoerce loc) 1 1 . castPtr
 
   clean _ = do
     GL.currentProgram $= (Nothing :: Maybe GL.Program)

app/Types/UserData.hs

@@ -45,11 +45,11 @@ data Subsystems = Subsystems
   , subMouse  :: SubMouse
   }
 
-newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData ())])
-newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
+newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
+newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
 
-instance Participant SubWindow UserData where
-  type Mesg SubWindow UserData = WindowMessage
+instance Participant SubWindow where
+  type Mesg SubWindow = WindowMessage
 
   partSubscribers (SubWindow t) = genericSubscribers t
 
@@ -57,11 +57,11 @@ instance Participant SubWindow UserData where
 
   partUnSubscribe (SubWindow t) = genericUnSubscribe t
 
-instance SDLSubsystem SubWindow UserData where
+instance SDLSubsystem SubWindow where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant SubMouse UserData where
-  type Mesg SubMouse UserData = MouseMessage
+instance Participant SubMouse where
+  type Mesg SubMouse = MouseMessage
 
   partSubscribers (SubMouse t) = genericSubscribers t
 
@@ -69,29 +69,29 @@ instance Participant SubMouse UserData where
 
   partUnSubscribe (SubMouse t) = genericUnSubscribe t
 
-instance SDLSubsystem SubMouse UserData where
+instance SDLSubsystem SubMouse where
   consumeSDLEvents = consumeSDLMouseEvents
 
 genericSubscribers
-  :: TVar [(UUID, msg -> Affection UserData ())]
-  -> Affection UserData [(msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
+  -> Affection [(msg -> Affection ())]
 genericSubscribers t = do
   subTups <- liftIO $ readTVarIO t
   return $ map snd subTups
 
 genericSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
-  -> (msg -> Affection UserData ())
-  -> Affection UserData UUID
+  :: TVar [(UUID, msg -> Affection ())]
+  -> (msg -> Affection ())
+  -> Affection UUID
 genericSubscribe t funct = do
   uu <- genUUID
   liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
   return uu
 
 genericUnSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
   -> UUID
-  -> Affection UserData ()
+  -> Affection ()
 genericUnSubscribe t uu =
   liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
   where

canvas.cabal

@@ -26,12 +26,11 @@ executable canvas
                        Renderer
   -- other-extensions:
   ghc-options:         -Wall
-  build-depends:       base ^>=4.12.0.0
+  build-depends:       base >= 4.12.0.0 && < 5
                      , affection
                      , sdl2 ^>=2.5.0.0
                      , OpenGL
                      , OpenGLRaw
-                     , GLUtil
                      , JuicyPixels
                      , JuicyPixels-extra
                      , stm

shell.nix

@@ -25,23 +25,23 @@ let
       doHaddock = false;
     }) {};
 
-  GLUtil = with haskellPackages; callPackage(
-    { mkDerivation, array, base, bytestring, containers, directory
-    , filepath, hpp, JuicyPixels, linear, OpenGL, OpenGLRaw, stdenv
-    , transformers, vector
-    }:
-    mkDerivation {
-      pname = "GLUtil";
-      version = "0.10.3";
-      sha256 = "1933540d309209fb90f0632336ee6c54e160a12da8508dadaf16882a2358ec27";
-      libraryHaskellDepends = [
-        array base bytestring containers directory filepath hpp JuicyPixels
-        linear OpenGL OpenGLRaw transformers vector
-      ];
-      libraryToolDepends = [ hpp ];
-      description = "Miscellaneous OpenGL utilities";
-      license = stdenv.lib.licenses.bsd3;
-    }) {};
+  #GLUtil = with haskellPackages; callPackage(
+  #  { mkDerivation, array, base, bytestring, containers, directory
+  #  , filepath, hpp, JuicyPixels, linear, OpenGL, OpenGLRaw, stdenv
+  #  , transformers, vector
+  #  }:
+  #  mkDerivation {
+  #    pname = "GLUtil";
+  #    version = "0.10.3";
+  #    sha256 = "1933540d309209fb90f0632336ee6c54e160a12da8508dadaf16882a2358ec27";
+  #    libraryHaskellDepends = [
+  #      array base bytestring containers directory filepath hpp JuicyPixels
+  #      linear OpenGL OpenGLRaw transformers vector
+  #    ];
+  #    libraryToolDepends = [ hpp ];
+  #    description = "Miscellaneous OpenGL utilities";
+  #    license = stdenv.lib.licenses.bsd3;
+  #  }) {};
 
   f = { mkDerivation, base, bytestring, containers
       , JuicyPixels, JuicyPixels-extra, linear, OpenGL, OpenGLRaw
@@ -54,7 +54,7 @@ let
         isLibrary = false;
         isExecutable = true;
         executableHaskellDepends = [
-          affection base bytestring containers GLUtil JuicyPixels
+          affection base bytestring containers JuicyPixels
           JuicyPixels-extra linear OpenGL OpenGLRaw random sdl2 stm
         ];
         description = "A test implementation for drawing images with SDL2 and OpenGL";