throw out more of GLUtil

app/Main.hs

@@ -8,7 +8,6 @@ import qualified SDL
 
 import qualified Graphics.Rendering.OpenGL as GL
 import qualified Graphics.GL as GLRaw
-import qualified Graphics.GLUtil as GLU
 
 import Codec.Picture
 
@@ -58,12 +57,15 @@ main =
 preLoopImpl :: Affection UserData ()
 preLoopImpl = liftIO $ do
   void $ SDL.setMouseLocationMode SDL.RelativeLocation
-  -- GL.depthFunc $= Just GL.Less
-  GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
-  GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge)
-  GL.texture GL.Texture2D $= GL.Enabled
-  -- GL.frontFace $= GL.CW
+  GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+  GL.frontFace $= GL.CCW
+  GL.blend $= GL.Enabled
+  GL.depthFunc $= Nothing
+  GL.scissor $= Nothing
+
   GL.viewport $= (GL.Position 0 0, GL.Size 1920 1080)
+  GL.clearColor $= GL.Color4 1 1 1 1
+
 
 loadStateImpl :: IO UserData
 loadStateImpl = do

app/Renderer.hs

@@ -6,7 +6,7 @@ import SDL (($=))
 
 import qualified Graphics.Rendering.OpenGL as GL
 import qualified Graphics.GL.Functions as GLRaw (glVertexAttribDivisor)
-import qualified Graphics.GLUtil as GLU
+-- import qualified Graphics.GLUtil as GLU
 
 import qualified Data.Map.Strict as M
 
@@ -101,10 +101,50 @@ rawVertices =
   ]
 
 initSpriteShaderObjects = do
+  -- vertexShaderSrc <- BS.readFile "shader/vertex.sl"
+  -- fragmentShaderSrc <- BS.readFile "shader/fragment.sl"
+
+  vertexShader <- createShader VertexShader
+  fragmentShader <- createShader FragmentShader
+
   vertexShaderSrc <- BS.readFile "shader/vertex.sl"
   fragmentShaderSrc <- BS.readFile "shader/fragment.sl"
 
-  shaderProgram <- GLU.simpleShaderProgramBS vertexShaderSrc fragmentShaderSrc
+  shaderSourceBS vertexShader $= vertexShaderSrc
+  shaderSourceBS fragmentShader $= fragmentShaderSrc
+
+  compileShader vertexShader
+  get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
+  vOK <- get (compileStatus vertexShader)
+  infoLog <- get (shaderInfoLog vertexShader)
+  unless (null infoLog || infoLog == "\NUL")
+    (mapM_
+      putStrLn
+      ["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
+      )
+  unless vOK $ do
+    deleteObjectName vertexShader
+    ioError (userError "vertexShader compilation failed")
+  compileShader fragmentShader
+  get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
+  fOK <- get (compileStatus fragmentShader)
+  infoLog <- get (shaderInfoLog fragmentShader)
+  unless (null infoLog || infoLog == "\NUL")
+    (mapM_
+      putStrLn
+      ["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
+      )
+  unless fOK $ do
+    deleteObjectName fragmentShader
+    ioError (userError "fragmentShader compilation failed")
+
+  -- shaderProgram <- GLU.simpleShaderProgramBS vertexShaderSrc fragmentShaderSrc
+
+  shaderProgram <- createProgram
+  attachShaders shaderProgram $= [vertexShader, fragmentShader]
+  linkProgram shaderProgram
+  get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
+
 
   return (SpriteShaderObjects shaderProgram)
 
@@ -149,6 +189,12 @@ loadSprites amount = do
       --   [ (V2 0 0)
       --   ]
 
+  GL.texture GL.Texture2D $= GL.Enabled
+  GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge)
+  GL.textureFilter GL.Texture2D $= ((GL.Nearest, Just GL.Nearest), GL.Nearest)
+  GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)
+  GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)
+
   textObj <- initSpriteTextureObjects lookups
 
   positions <- replicateM amount $ do

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,20 +46,19 @@ 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
-      GL.clearColor $= GL.Color4 1 1 1 1
       -- let projection = ortho (-960) 960 (-540) 540 (-1) 1 :: M44 Float
       -- GLU.setUniform prog "projection" (projection)
 
   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
@@ -59,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

nix/sources.json

@@ -1,45 +0,0 @@
-{
-    "affection": {
-        "branch": "master",
-        "description": "A simple Game Engine in Haskell using SDL",
-        "homepage": "",
-        "owner": "nek0",
-        "repo": "affection",
-        "rev": "18775515d8d569c36148c02a134e1f538981b1ff",
-        "sha256": "09bxf917mj1lanc0d5f7xj3n22dk8drzgqivqpnvskdx88pmrv4k",
-        "type": "tarball",
-        "url": "https://github.com/nek0/affection/archive/18775515d8d569c36148c02a134e1f538981b1ff.tar.gz",
-        "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
-    },
-    "ghc": {
-        "sha256": "1pqlx6rdjs2110g0y1i9f8x18lmdizibjqd15f5xahcz39hgaxdw",
-        "type": "file",
-        "url": "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz",
-        "url_template": "https://downloads.haskell.org/~ghc/<version>/ghc-<version>-x86_64-deb9-linux.tar.xz",
-        "version": "8.6.5"
-    },
-    "niv": {
-        "branch": "master",
-        "description": "Easy dependency management for Nix projects",
-        "homepage": "https://github.com/nmattia/niv",
-        "owner": "nmattia",
-        "repo": "niv",
-        "rev": "7a21f49027c0901456acd6e61d91bd9e3b15b1f6",
-        "sha256": "1hrcjgz4ib5n6wm96gcjk2qjl03pvspksk48b2lkn29vpdry98jm",
-        "type": "tarball",
-        "url": "https://github.com/nmattia/niv/archive/7a21f49027c0901456acd6e61d91bd9e3b15b1f6.tar.gz",
-        "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
-    },
-    "nixpkgs": {
-        "branch": "nixos-19.09",
-        "description": "A read-only mirror of NixOS/nixpkgs tracking the released channels. Send issues and PRs to",
-        "homepage": "https://github.com/NixOS/nixpkgs",
-        "owner": "NixOS",
-        "repo": "nixpkgs-channels",
-        "rev": "d3d2de8b99be56c5a6ed18f46e280f8103124dd7",
-        "sha256": "1chzbajrspw24csnv2c0h1h59pbp1k6939cllmd61382p9iw7rg8",
-        "type": "tarball",
-        "url": "https://github.com/NixOS/nixpkgs-channels/archive/d3d2de8b99be56c5a6ed18f46e280f8103124dd7.tar.gz",
-        "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
-    }
-}

nix/sources.nix

@@ -1,134 +0,0 @@
-# This file has been generated by Niv.
-
-let
-
-  #
-  # The fetchers. fetch_<type> fetches specs of type <type>.
-  #
-
-  fetch_file = pkgs: spec:
-    if spec.builtin or true then
-      builtins_fetchurl { inherit (spec) url sha256; }
-    else
-      pkgs.fetchurl { inherit (spec) url sha256; };
-
-  fetch_tarball = pkgs: spec:
-    if spec.builtin or true then
-      builtins_fetchTarball { inherit (spec) url sha256; }
-    else
-      pkgs.fetchzip { inherit (spec) url sha256; };
-
-  fetch_git = spec:
-    builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
-
-  fetch_builtin-tarball = spec:
-    builtins.trace
-      ''
-        WARNING:
-          The niv type "builtin-tarball" will soon be deprecated. You should
-          instead use `builtin = true`.
-
-          $ niv modify <package> -a type=tarball -a builtin=true
-      ''
-      builtins_fetchTarball { inherit (spec) url sha256; };
-
-  fetch_builtin-url = spec:
-    builtins.trace
-      ''
-        WARNING:
-          The niv type "builtin-url" will soon be deprecated. You should
-          instead use `builtin = true`.
-
-          $ niv modify <package> -a type=file -a builtin=true
-      ''
-      (builtins_fetchurl { inherit (spec) url sha256; });
-
-  #
-  # Various helpers
-  #
-
-  # The set of packages used when specs are fetched using non-builtins.
-  mkPkgs = sources:
-    let
-      sourcesNixpkgs =
-        import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
-      hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
-      hasThisAsNixpkgsPath = <nixpkgs> == ./.;
-    in
-      if builtins.hasAttr "nixpkgs" sources
-      then sourcesNixpkgs
-      else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
-        import <nixpkgs> {}
-      else
-        abort
-          ''
-            Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
-            add a package called "nixpkgs" to your sources.json.
-          '';
-
-  # The actual fetching function.
-  fetch = pkgs: name: spec:
-
-    if ! builtins.hasAttr "type" spec then
-      abort "ERROR: niv spec ${name} does not have a 'type' attribute"
-    else if spec.type == "file" then fetch_file pkgs spec
-    else if spec.type == "tarball" then fetch_tarball pkgs spec
-    else if spec.type == "git" then fetch_git spec
-    else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec
-    else if spec.type == "builtin-url" then fetch_builtin-url spec
-    else
-      abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
-
-  # Ports of functions for older nix versions
-
-  # a Nix version of mapAttrs if the built-in doesn't exist
-  mapAttrs = builtins.mapAttrs or (
-    f: set: with builtins;
-    listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
-  );
-
-  # fetchTarball version that is compatible between all the versions of Nix
-  builtins_fetchTarball = { url, sha256 }@attrs:
-    let
-      inherit (builtins) lessThan nixVersion fetchTarball;
-    in
-      if lessThan nixVersion "1.12" then
-        fetchTarball { inherit url; }
-      else
-        fetchTarball attrs;
-
-  # fetchurl version that is compatible between all the versions of Nix
-  builtins_fetchurl = { url, sha256 }@attrs:
-    let
-      inherit (builtins) lessThan nixVersion fetchurl;
-    in
-      if lessThan nixVersion "1.12" then
-        fetchurl { inherit url; }
-      else
-        fetchurl attrs;
-
-  # Create the final "sources" from the config
-  mkSources = config:
-    mapAttrs (
-      name: spec:
-        if builtins.hasAttr "outPath" spec
-        then abort
-          "The values in sources.json should not have an 'outPath' attribute"
-        else
-          spec // { outPath = fetch config.pkgs name spec; }
-    ) config.sources;
-
-  # The "config" used by the fetchers
-  mkConfig =
-    { sourcesFile ? ./sources.json
-    , sources ? builtins.fromJSON (builtins.readFile sourcesFile)
-    , pkgs ? mkPkgs sources
-    }: rec {
-      # The sources, i.e. the attribute set of spec name to spec
-      inherit sources;
-
-      # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
-      inherit pkgs;
-    };
-in
-mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

shell.nix

@@ -1,6 +1,74 @@
-{ pkgs ? import <nixpkgs> {} }:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
 
 let
-  hsPkgs = import ./default.nix;
+
+  inherit (nixpkgs) pkgs;
+
+  affection = with haskellPackages; callPackage(
+    { mkDerivation, base, bytestring, clock, containers, glib, linear
+    , monad-loops, monad-parallel, mtl, OpenGL, sdl2, stdenv, stm, text
+    , uuid, vector
+    }:
+    mkDerivation {
+      pname = "affection";
+      version = "0.0.0.10";
+      src = ../affection;
+      isLibrary = true;
+      isExecutable = true;
+      libraryHaskellDepends = [
+        base bytestring clock containers glib linear monad-loops
+        monad-parallel mtl OpenGL sdl2 stm text uuid vector
+      ];
+      homepage = "https://github.com/nek0/affection#readme";
+      description = "A simple Game Engine using SDL";
+      license = stdenv.lib.licenses.lgpl3;
+      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;
+  #  }) {};
+
+  f = { mkDerivation, base, bytestring, containers
+      , JuicyPixels, JuicyPixels-extra, linear, OpenGL, OpenGLRaw
+      , random, sdl2, stdenv, stm
+      }:
+      mkDerivation {
+        pname = "canvas";
+        version = "0.0.0.0";
+        src = ./.;
+        isLibrary = false;
+        isExecutable = true;
+        executableHaskellDepends = [
+          affection base bytestring containers JuicyPixels
+          JuicyPixels-extra linear OpenGL OpenGLRaw random sdl2 stm
+        ];
+        description = "A test implementation for drawing images with SDL2 and OpenGL";
+        license = stdenv.lib.licenses.bsd3;
+      };
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
+
+  drv = variant (haskellPackages.callPackage f {});
+
 in
-  hsPkgs.canvas.components.all
+
+  if pkgs.lib.inNixShell then drv.env else drv