--------------------------------------------------------------------------------
-- |
-- Module      :  LoadShaders
-- Copyright   :  (c) Sven Panne 2013
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The
-- Red Book Authors.
--
--------------------------------------------------------------------------------


module Graphics.RedViz.LoadShaders (
   ShaderSource(..), ShaderInfo(..), loadShaders
) where

import Control.Exception
import Control.Monad
import qualified Data.ByteString as B
import Graphics.Rendering.OpenGL
-- import Debug.Trace as DT

--------------------------------------------------------------------------------

-- | The source of the shader source code.

data ShaderSource =
     ByteStringSource B.ByteString
     -- ^ The shader source code is directly given as a 'B.ByteString'.
   | StringSource String
     -- ^ The shader source code is directly given as a 'String'.
   | FileSource FilePath
     -- ^ The shader source code is located in the file at the given 'FilePath'.
   deriving ( ShaderSource -> ShaderSource -> Bool
(ShaderSource -> ShaderSource -> Bool)
-> (ShaderSource -> ShaderSource -> Bool) -> Eq ShaderSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShaderSource -> ShaderSource -> Bool
$c/= :: ShaderSource -> ShaderSource -> Bool
== :: ShaderSource -> ShaderSource -> Bool
$c== :: ShaderSource -> ShaderSource -> Bool
Eq, Eq ShaderSource
Eq ShaderSource
-> (ShaderSource -> ShaderSource -> Ordering)
-> (ShaderSource -> ShaderSource -> Bool)
-> (ShaderSource -> ShaderSource -> Bool)
-> (ShaderSource -> ShaderSource -> Bool)
-> (ShaderSource -> ShaderSource -> Bool)
-> (ShaderSource -> ShaderSource -> ShaderSource)
-> (ShaderSource -> ShaderSource -> ShaderSource)
-> Ord ShaderSource
ShaderSource -> ShaderSource -> Bool
ShaderSource -> ShaderSource -> Ordering
ShaderSource -> ShaderSource -> ShaderSource
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShaderSource -> ShaderSource -> ShaderSource
$cmin :: ShaderSource -> ShaderSource -> ShaderSource
max :: ShaderSource -> ShaderSource -> ShaderSource
$cmax :: ShaderSource -> ShaderSource -> ShaderSource
>= :: ShaderSource -> ShaderSource -> Bool
$c>= :: ShaderSource -> ShaderSource -> Bool
> :: ShaderSource -> ShaderSource -> Bool
$c> :: ShaderSource -> ShaderSource -> Bool
<= :: ShaderSource -> ShaderSource -> Bool
$c<= :: ShaderSource -> ShaderSource -> Bool
< :: ShaderSource -> ShaderSource -> Bool
$c< :: ShaderSource -> ShaderSource -> Bool
compare :: ShaderSource -> ShaderSource -> Ordering
$ccompare :: ShaderSource -> ShaderSource -> Ordering
$cp1Ord :: Eq ShaderSource
Ord, Int -> ShaderSource -> ShowS
[ShaderSource] -> ShowS
ShaderSource -> String
(Int -> ShaderSource -> ShowS)
-> (ShaderSource -> String)
-> ([ShaderSource] -> ShowS)
-> Show ShaderSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShaderSource] -> ShowS
$cshowList :: [ShaderSource] -> ShowS
show :: ShaderSource -> String
$cshow :: ShaderSource -> String
showsPrec :: Int -> ShaderSource -> ShowS
$cshowsPrec :: Int -> ShaderSource -> ShowS
Show )

getSource :: ShaderSource -> IO B.ByteString
getSource :: ShaderSource -> IO ByteString
getSource (ByteStringSource ByteString
bs) = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
getSource (StringSource String
str) = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
packUtf8 String
str
getSource (FileSource String
path) = String -> IO ByteString
B.readFile String
path

--------------------------------------------------------------------------------

-- | A description of a shader: The type of the shader plus its source code.

data ShaderInfo = ShaderInfo ShaderType ShaderSource
   deriving ( ShaderInfo -> ShaderInfo -> Bool
(ShaderInfo -> ShaderInfo -> Bool)
-> (ShaderInfo -> ShaderInfo -> Bool) -> Eq ShaderInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShaderInfo -> ShaderInfo -> Bool
$c/= :: ShaderInfo -> ShaderInfo -> Bool
== :: ShaderInfo -> ShaderInfo -> Bool
$c== :: ShaderInfo -> ShaderInfo -> Bool
Eq, Eq ShaderInfo
Eq ShaderInfo
-> (ShaderInfo -> ShaderInfo -> Ordering)
-> (ShaderInfo -> ShaderInfo -> Bool)
-> (ShaderInfo -> ShaderInfo -> Bool)
-> (ShaderInfo -> ShaderInfo -> Bool)
-> (ShaderInfo -> ShaderInfo -> Bool)
-> (ShaderInfo -> ShaderInfo -> ShaderInfo)
-> (ShaderInfo -> ShaderInfo -> ShaderInfo)
-> Ord ShaderInfo
ShaderInfo -> ShaderInfo -> Bool
ShaderInfo -> ShaderInfo -> Ordering
ShaderInfo -> ShaderInfo -> ShaderInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShaderInfo -> ShaderInfo -> ShaderInfo
$cmin :: ShaderInfo -> ShaderInfo -> ShaderInfo
max :: ShaderInfo -> ShaderInfo -> ShaderInfo
$cmax :: ShaderInfo -> ShaderInfo -> ShaderInfo
>= :: ShaderInfo -> ShaderInfo -> Bool
$c>= :: ShaderInfo -> ShaderInfo -> Bool
> :: ShaderInfo -> ShaderInfo -> Bool
$c> :: ShaderInfo -> ShaderInfo -> Bool
<= :: ShaderInfo -> ShaderInfo -> Bool
$c<= :: ShaderInfo -> ShaderInfo -> Bool
< :: ShaderInfo -> ShaderInfo -> Bool
$c< :: ShaderInfo -> ShaderInfo -> Bool
compare :: ShaderInfo -> ShaderInfo -> Ordering
$ccompare :: ShaderInfo -> ShaderInfo -> Ordering
$cp1Ord :: Eq ShaderInfo
Ord, Int -> ShaderInfo -> ShowS
[ShaderInfo] -> ShowS
ShaderInfo -> String
(Int -> ShaderInfo -> ShowS)
-> (ShaderInfo -> String)
-> ([ShaderInfo] -> ShowS)
-> Show ShaderInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShaderInfo] -> ShowS
$cshowList :: [ShaderInfo] -> ShowS
show :: ShaderInfo -> String
$cshow :: ShaderInfo -> String
showsPrec :: Int -> ShaderInfo -> ShowS
$cshowsPrec :: Int -> ShaderInfo -> ShowS
Show )

--------------------------------------------------------------------------------

-- | Create a new program object from the given shaders, throwing an
-- 'IOException' if something goes wrong.

loadShaders :: [ShaderInfo] -> IO Program
loadShaders :: [ShaderInfo] -> IO Program
loadShaders [ShaderInfo]
infos =
   IO Program
createProgram IO Program
-> (Program -> IO ()) -> (Program -> IO Program) -> IO Program
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
`bracketOnError` Program -> IO ()
forall a (m :: * -> *). (ObjectName a, MonadIO m) => a -> m ()
deleteObjectName ((Program -> IO Program) -> IO Program)
-> (Program -> IO Program) -> IO Program
forall a b. (a -> b) -> a -> b
$ \Program
program -> do
      --_ <- DT.trace ("loadShaders.hs: Loading Shader Program :" ++ show infos) $ return ()
      Program -> [ShaderInfo] -> IO ()
loadCompileAttach Program
program [ShaderInfo]
infos
      Program -> IO ()
linkAndCheck Program
program
      Program -> IO Program
forall (m :: * -> *) a. Monad m => a -> m a
return Program
program

linkAndCheck :: Program -> IO ()
linkAndCheck :: Program -> IO ()
linkAndCheck = (Program -> IO ())
-> (Program -> GettableStateVar Bool)
-> (Program -> GettableStateVar String)
-> String
-> Program
-> IO ()
forall t.
(t -> IO ())
-> (t -> GettableStateVar Bool)
-> (t -> GettableStateVar String)
-> String
-> t
-> IO ()
checked Program -> IO ()
linkProgram Program -> GettableStateVar Bool
linkStatus Program -> GettableStateVar String
programInfoLog String
"link"

loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
loadCompileAttach Program
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loadCompileAttach Program
program (ShaderInfo ShaderType
shType ShaderSource
source : [ShaderInfo]
infos) =
   ShaderType -> IO Shader
createShader ShaderType
shType IO Shader -> (Shader -> IO ()) -> (Shader -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
`bracketOnError` Shader -> IO ()
forall a (m :: * -> *). (ObjectName a, MonadIO m) => a -> m ()
deleteObjectName ((Shader -> IO ()) -> IO ()) -> (Shader -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Shader
shader -> do
      -- _ <- DT.trace ("Loading Shader Program" ++ show program ++ show source) $ return ()
      ByteString
src <- ShaderSource -> IO ByteString
getSource ShaderSource
source
      Shader -> StateVar ByteString
shaderSourceBS Shader
shader StateVar ByteString -> ByteString -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ByteString
src
      Shader -> IO ()
compileAndCheck Shader
shader
      Program -> Shader -> IO ()
attachShader Program
program Shader
shader
      Program -> [ShaderInfo] -> IO ()
loadCompileAttach Program
program [ShaderInfo]
infos

compileAndCheck :: Shader -> IO ()
compileAndCheck :: Shader -> IO ()
compileAndCheck = (Shader -> IO ())
-> (Shader -> GettableStateVar Bool)
-> (Shader -> GettableStateVar String)
-> String
-> Shader
-> IO ()
forall t.
(t -> IO ())
-> (t -> GettableStateVar Bool)
-> (t -> GettableStateVar String)
-> String
-> t
-> IO ()
checked Shader -> IO ()
compileShader Shader -> GettableStateVar Bool
compileStatus Shader -> GettableStateVar String
shaderInfoLog String
"compile"

checked :: (t -> IO ())
        -> (t -> GettableStateVar Bool)
        -> (t -> GettableStateVar String)
        -> String
        -> t
        -> IO ()
checked :: (t -> IO ())
-> (t -> GettableStateVar Bool)
-> (t -> GettableStateVar String)
-> String
-> t
-> IO ()
checked t -> IO ()
action t -> GettableStateVar Bool
getStatus t -> GettableStateVar String
getInfoLog String
message t
object = do
   t -> IO ()
action t
object
   Bool
ok <- GettableStateVar Bool -> GettableStateVar Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (t -> GettableStateVar Bool
getStatus t
object)
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String
infoLog <- GettableStateVar String -> GettableStateVar String
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (t -> GettableStateVar String
getInfoLog t
object)
      String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
message String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" log: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
infoLog)