Implement experimental type-safe DSL for the GLSL

More of a playground for type-level stuff

Author: kcsongor

haskell-doom.cabal

@@ -19,6 +19,6 @@ executable haskell-doom
   main-is:             Main.hs
   -- other-modules:
   -- other-extensions:
-  build-depends:       base >=4.8 && <4.9, GLFW-b >=1.4 && <1.5, delaunay, AC-Vector, OpenGLRaw >=3.0.0, linear, waddle, containers, transformers, mtl, case-insensitive, array, bytestring
+  build-depends:       base >=4.8 && <4.9, GLFW-b >=1.4 && <1.5, delaunay, AC-Vector, OpenGLRaw >=3.0.0, linear, waddle, containers, transformers, mtl, case-insensitive, array, bytestring, free
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Var.hs renamed to src/Data/Var.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
-module Var where
+module Data.Var where
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Data.IORef

src/Game.hs

@@ -14,7 +14,7 @@ import           Linear
 import           Data.IORef
 import           Enemy
 import           Types
-import           Var
+import           Data.Var
 
 newtype GameMonad e a = GameMonad { unGame :: ReaderT e IO a }
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader e)

src/GLUtils.hs renamed to src/Graphics/Binding.hs

@@ -1,20 +1,51 @@
-{-# LANGUAGE FlexibleInstances,
-             ScopedTypeVariables,
-             FlexibleContexts,
-             DataKinds,
-             TypeFamilies,
-             MultiParamTypeClasses,
-             ExistentialQuantification #-}
-module GLUtils where
-import Var
-import Graphics.GL.Core33
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Graphics.Binding where
+import Control.Monad
 import Control.Monad.IO.Class
-import Foreign.C.String
+import Data.Proxy
+import Data.Var
 import Foreign
+import Foreign.C.String
+import GHC.TypeLits
+import Graphics.GL
+import Graphics.Program
+import Graphics.Shader
 import Linear
-import Control.Monad
 
-type ProgId = GLuint
+data Bindable (k :: [(Symbol, GLSLType)]) a = Bindable [a]
+
+bindVertexData :: forall a i u m.
+    (Storable a, GLTypeable a, TypeInfo i, MonadIO m) =>
+    Program i u -> Bindable i a -> m ()
+bindVertexData (Program progId) (Bindable bdata) = liftIO $ do
+    withArrayLen bdata $ \len vertices ->
+        glBufferData GL_ARRAY_BUFFER
+                     (fromIntegral $ len * dataSize)
+                     (vertices :: Ptr a)
+                     GL_STATIC_DRAW
+    foldM_ (\offset (name, size) -> do
+            attrib <- get $ AttribLocation progId name
+            glEnableVertexAttribArray attrib
+            glVertexAttribPointer attrib
+                                  size
+                                  (glType proxy)
+                                  (fromBool False)
+                                  (fromIntegral $ totalSize * dataSize)
+                                  offset
+            return (offset `plusPtr` fromIntegral (size * fromIntegral dataSize))
+        ) nullPtr (map (fmap (fromIntegral . glslTypeSize)) extracted)
+    where extracted = extract (Proxy :: Proxy i)
+          totalSize = fromIntegral $ sum . map (glslTypeSize . snd) $ extracted
+          dataSize  = sizeOf proxy
+          proxy   = undefined :: a
 
 -- Attribute location
 data AttribLocation a = AttribLocation ProgId String
@@ -26,37 +57,37 @@ instance (MonadIO m, Num a) => HasGetter m (AttribLocation a) a where
 -- Uniform binding
 data Uniform a = Uniform ProgId String
 
-instance (MonadIO m, UniformBinding a, Storable a) => HasSetter m (Uniform a) a where
+instance (MonadIO m, HasBinder a) => HasSetter m (Uniform a) a where
     (Uniform progId name) $= uniData = liftIO $ do
         uniId <- withCString name $ glGetUniformLocation progId
         bindUniform uniData (fromIntegral uniId) 1
 
-class Storable v => UniformBinding v where
+class Storable v => HasBinder v where
     bindFunc :: v -> GLint -> GLsizei -> Ptr a -> IO ()
     bindUniform :: MonadIO m => v -> GLint -> GLsizei -> m ()
     bindUniform val loc count = liftIO $
             with val $ \trans -> bindFunc val loc count trans
 
-instance UniformBinding (M44 GLfloat) where
+instance HasBinder (M44 GLfloat) where
     bindFunc _ = matrixBinder glUniformMatrix4fv
 
-instance UniformBinding (M33 GLfloat) where
+instance HasBinder (M33 GLfloat) where
     bindFunc _ = matrixBinder glUniformMatrix3fv
 
-instance UniformBinding (M23 GLfloat) where
+instance HasBinder (M23 GLfloat) where
     bindFunc _ = matrixBinder glUniformMatrix2x3fv
 -- TODO: add other matrices
 
-instance UniformBinding (V4 GLfloat) where
+instance HasBinder (V4 GLfloat) where
     bindFunc _ = vectorBinder glUniform4fv
 
-instance UniformBinding (V3 GLfloat) where
+instance HasBinder (V3 GLfloat) where
     bindFunc _ = vectorBinder glUniform3fv
 
-instance UniformBinding (V2 GLfloat) where
+instance HasBinder (V2 GLfloat) where
     bindFunc _ = vectorBinder glUniform2fv
 
-instance UniformBinding (V1 GLfloat) where
+instance HasBinder (V1 GLfloat) where
     bindFunc _ = vectorBinder glUniform1fv
 -- TODO: add other vectors (GLint)
 
@@ -72,31 +103,7 @@ vectorBinder :: MonadIO m =>
 vectorBinder f loc count val
     = liftIO $ f loc count (castPtr val)
 
--- Misc aux. functions
-offsetPtr :: Storable a => Int -> a -> Ptr GLvoid
-offsetPtr x s = plusPtr nullPtr (fromIntegral $ x * sizeOf s)
-
-withNewPtr :: Storable a => (Ptr a -> IO b) -> IO a
-withNewPtr f = alloca (\p -> f p >> get p)
-
-loadShader :: GLenum -> FilePath -> IO GLuint
-loadShader shaderTypeFlag filePath = do
-  code <- readFile filePath
-  shader <- glCreateShader shaderTypeFlag
-  withCString code $ \codePtr ->
-    with codePtr $ \codePtrPtr ->
-      glShaderSource shader 1 codePtrPtr nullPtr
-  glCompileShader shader
-  status <- toBool <$> withNewPtr (glGetShaderiv shader GL_COMPILE_STATUS)
-  unless status $
-      alloca $ \err -> do
-          glGetShaderInfoLog shader 512 nullPtr err
-          err' <- peekCString err
-          error err'
-  return shader
-
 -- Fragment shader
-
 data FragmentShaderField
     = FragDiffuseColor  -- 0
     | FragMaterialID    -- 1
@@ -112,14 +119,3 @@ instance MonadIO m => HasSetter m FragShaderLocation FragmentShaderField where
         = liftIO . withCString name $
             glBindFragDataLocation progId (fromIntegral $ fromEnum loc)
 
--- GL typeable stuff
-class GLTypeable a where
-    glType :: a -> Word32
-
-instance GLTypeable GLfloat where
-    glType _ = GL_FLOAT
-
-instance GLTypeable GLint where
-    glType _ = GL_INT
-
--- TODO: etc

src/Graphics/GLUtils.hs

@@ -0,0 +1,35 @@
+module Graphics.GLUtils where
+import Data.Var
+import Graphics.GL
+import Foreign.C.String
+import Foreign
+import Control.Monad
+
+-- Misc aux. functions
+offsetPtr :: Storable a => Int -> a -> Ptr GLvoid
+offsetPtr x s = plusPtr nullPtr (fromIntegral $ x * sizeOf s)
+
+withNewPtr :: Storable a => (Ptr a -> IO b) -> IO a
+withNewPtr f = alloca (\p -> f p >> get p)
+
+shaderFromString :: GLenum -> String -> IO GLuint
+shaderFromString shaderTypeFlag code = do
+    shader <- glCreateShader shaderTypeFlag
+    withCString code $ \codePtr ->
+      with codePtr $ \codePtrPtr ->
+        glShaderSource shader 1 codePtrPtr nullPtr
+    glCompileShader shader
+    status <- toBool <$> withNewPtr (glGetShaderiv shader GL_COMPILE_STATUS)
+    unless status $
+        alloca $ \err -> do
+            glGetShaderInfoLog shader 512 nullPtr err
+            err' <- peekCString err
+            error err'
+    return shader
+
+
+loadShader :: GLenum -> FilePath -> IO GLuint
+loadShader shaderTypeFlag filePath = do
+  code <- readFile filePath
+  shaderFromString shaderTypeFlag code
+

src/Graphics/Program.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+module Graphics.Program where
+
+import Graphics.Shader
+import GHC.TypeLits
+import Graphics.GL
+import Graphics.GLUtils
+
+type ProgId = GLuint
+
+data Program (inputs   :: [(Symbol, GLSLType)])
+             (uniforms :: [(Symbol, GLSLType)])
+             = Program ProgId
+
+mkProgram :: ( KnownNat ver
+             , TypeInfo i
+             , TypeInfo o
+             , TypeInfo u
+             , TypeInfo o'
+             , TypeInfo u' ) =>
+             Shader ver i o u a -> Shader ver o o' u' a' -> IO (Program i (Union u u'))
+mkProgram vert frag = do
+    progId <- glCreateProgram
+    vertS <- shaderFromString GL_VERTEX_SHADER (showShader vert)
+    fragS <- shaderFromString GL_FRAGMENT_SHADER (showShader frag)
+    glAttachShader progId vertS
+    glAttachShader progId fragS
+
+    glLinkProgram progId
+    glUseProgram progId
+    glDeleteShader vertS
+    glDeleteShader fragS
+    return $ Program progId

src/Graphics/Shader.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Graphics.Shader
+    ( I.Shader(..)
+    , I.showShader
+    , T.GLSLType
+    , T.GLTypeable(..)
+    , T.TypeInfo(..)
+    , I.Union
+    , wallFrag
+    , wallVert
+    , spriteFrag
+    , spriteVert
+    , floorFrag
+    , floorVert
+    , glslTypeSize
+    , Pos3
+    , Tex2) where
+import Graphics.Shader.Internal as I
+import Graphics.Shader.Types as T
+import Graphics.Shader.Language as L
+
+-- TODO: swizzling
+
+type Pos3
+    = '("position", 'Vec3)
+pos3 :: SVar Pos3
+pos3 = SVar
+
+type Tex2
+    = '("texcoord", 'Vec2)
+tex2 :: SVar Tex2
+tex2 = SVar
+
+type Texcoord
+    = '("Texcoord", 'Vec2)
+texcoord :: SVar Texcoord
+texcoord = SVar
+
+type GlPos
+    = '("gl_Position", 'Vec4)
+glPos :: SVar GlPos
+glPos = SVar
+
+type Model
+    = '("model", 'Mat4)
+model :: SVar Model
+model = SVar
+
+type View
+    = '("view", 'Mat4)
+view :: SVar View
+view = SVar
+
+type Proj
+    = '("proj", 'Mat4)
+proj :: SVar Proj
+proj = SVar
+
+type Outcolor
+    = '("outColor", 'Vec4)
+outcolor :: SVar Outcolor
+outcolor = SVar
+
+type TexSampler
+    = '("tex", 'Sampler2D)
+texSampler :: SVar TexSampler
+texSampler = SVar
+
+wallVert :: Shader 150 '[Pos3, Tex2] '[Texcoord] '[Model, View, Proj] ()
+wallVert = do
+    out texcoord =: inp tex2
+    var glPos =: (uni proj *: uni view *: uni model *: (inp pos3 &: float 1.0))
+
+wallFrag :: Shader 150 '[Texcoord] '[Outcolor] '[TexSampler] ()
+wallFrag
+    = out outcolor =: texture (uni texSampler) (inp texcoord)
+
+spriteVert :: Shader 150 '[Pos3, Tex2] '[Texcoord] '[] ()
+spriteVert = do
+    out texcoord =: inp tex2
+    var glPos    =: inp pos3 &: float 1.0
+
+-- TODO: the sprite shader shouldn't be the same as wall shader
+spriteFrag :: Shader 150 '[Texcoord] '[Outcolor] '[TexSampler] ()
+spriteFrag = wallFrag
+
+floorVert :: Shader 150 '[Pos3] '[] '[Model, View, Proj] ()
+floorVert
+    = var glPos =: uni proj *: uni view *: uni model *: (inp pos3 &: pure (Scalar 1))
+
+floorFrag :: Shader 150 '[] '[Outcolor] '[] ()
+floorFrag
+    = out outcolor =: float 0.2 &: float 0.2 &: float 0.2 &: float 1.0