1 files changed, 109 insertions, 0 deletions
diff --git a/Graphics/Glyph/Shaders.hs b/Graphics/Glyph/Shaders.hs
new file mode 100644
index 0000000..01f27b6
--- /dev/null
+++ b/Graphics/Glyph/Shaders.hs
@@ -0,0 +1,109 @@
+module Graphics.Glyph.Shaders where
+
+import Graphics.Rendering.OpenGL
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import Control.Monad
+import Data.Maybe
+import Data.List as List
+import Graphics.Glyph.Util
+
+{- Load a shader from a file giving the type of the shader
+ - to load.
+ - This function returns the shader log as a string and
+ - a shader as a maybe. Nothing if the shader didn't complie
+ - and Just if the shader did compile
+ -}
+class IsShaderSource a where
+    loadShader :: ShaderType -> a -> IO (String, Maybe Shader)
+
+instance IsShaderSource FilePath where
+    loadShader typ path = loadShader typ =<< BS.readFile path
+
+instance IsShaderSource BS.ByteString where
+    loadShader typ src = do
+        shader <- createShader typ
+        shaderSourceBS shader $= src
+        compileShader shader
+    
+        ok <- get (compileStatus shader)
+        infoLog <- get (shaderInfoLog shader)
+    
+        unless ok $
+            deleteObjectNames [shader]
+    
+        return ( infoLog, if not ok then Nothing else Just shader );
+
+instance IsShaderSource BSL.ByteString where
+    loadShader typ = loadShader typ . toStrict
+        where toStrict = BS.concat . BSL.toChunks
+
+
+{- Load multiple shaders -}
+loadShaders :: (IsShaderSource a) => [(ShaderType,a)] -> IO [(String, Maybe Shader)]
+loadShaders = mapM ( uncurry loadShader )
+
+{- Return the sucessfully complied shaders
+ - as a new array of working shaders -}
+workingShaders :: [(a, Maybe Shader)] -> [Shader]
+workingShaders = mapMaybe snd
+
+{- Create a program from a list of working shaders -}
+createShaderProgram :: [Shader] -> IO (String, Maybe Program)
+createShaderProgram shaders = do
+    p <- createProgram
+    mapM_ (attachShader p) shaders
+    linkProgram p
+
+    ok <- get $ linkStatus p
+    info <- get $ programInfoLog p
+
+    unless ok $
+        deleteObjectNames [p]
+
+    return ( info, not ok ? Nothing $ Just p )
+
+{- Creates a shader program, but will only build the program if all the
+ - shaders compiled correctly -}
+createShaderProgramSafe :: [(String,Maybe Shader)] -> IO (String, Maybe Program)
+createShaderProgramSafe shaders = 
+    not (List.all (isJust.snd) shaders) ?
+        return (concatMap fst shaders, Nothing) $
+        createShaderProgram $ workingShaders shaders
+        
+
+{- Get the uniform form a program. -}
+getUniform :: Uniform a => String -> IO (Maybe (StateVar a))
+getUniform name =
+    get currentProgram >>= (\pr -> case pr of
+            Just p -> liftM (Just . uniform) (get $ uniformLocation p name)
+            Nothing -> return Nothing )
+
+getUniformForProgram :: Uniform a => String -> Program -> IO (StateVar a)
+getUniformForProgram name prog =
+    liftM uniform (get $ uniformLocation prog name)
+    
+
+getUniformLocation :: String -> IO (Maybe UniformLocation)
+getUniformLocation name =
+    get currentProgram >>= maybe (return Nothing) (\prog ->
+        liftM Just (get $ uniformLocation prog name) )
+
+loadProgramSafe ::
+    (IsShaderSource a,
+     IsShaderSource b,
+     IsShaderSource c) =>
+        a -> b -> Maybe c -> IO (Maybe Program)
+loadProgramSafe vert frag geom = do
+    shaders <- sequence $ catMaybes [
+        Just $ loadShader VertexShader vert,
+        Just $ loadShader FragmentShader frag,
+        liftM (loadShader GeometryShader) geom]
+    -- mapM_ (putStrLn . fst) shaders
+    (linklog, maybeProg) <- createShaderProgramSafe shaders
+
+    if isNothing maybeProg then do
+        putStrLn "Failed to link program"
+        putStrLn linklog
+        return Nothing
+        else return maybeProg