{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeFamilies               #-}

{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Graphics.GPipe.Internal.Shader (
    Shader(..),
    ShaderM(..),
    ShaderState(..),
    CompiledShader,
    Render(..),
    getNewName,
    tellDrawcall,
    askUniformAlignment,
    modifyRenderIO,
    compileShader,
    mapShader,
    guard',
    maybeShader,
    chooseShader,
    silenceShader
) where

import           Control.Applicative              (Alternative, (<|>))
import           Control.Monad                    (MonadPlus, forM)
import           Control.Monad.Exception          (MonadException)
import           Control.Monad.IO.Class           (MonadIO)
import           Control.Monad.Trans.Class        (lift)
import           Control.Monad.Trans.List         (ListT (..))
import           Control.Monad.Trans.Reader       (ReaderT (..), ask)
import           Control.Monad.Trans.State        (State, get, modify, put,
                                                   runState)
import           Control.Monad.Trans.Writer.Lazy  (WriterT (..), execWriterT,
                                                   tell)
import           Data.Either                      (isLeft, isRight)
import           Data.List                        (find)
import           Data.Maybe                       (fromJust, isJust, isNothing)
import           Data.Monoid                      (All (..))
import           Graphics.GPipe.Internal.Buffer   (UniformAlignment,
                                                   getUniformAlignment)
import           Graphics.GPipe.Internal.Compiler (CompiledShader, Drawcall,
                                                   RenderIOState,
                                                   compileDrawcalls,
                                                   mapDrawcall,
                                                   mapRenderIOState,
                                                   newRenderIOState)
import           Graphics.GPipe.Internal.Context  (ContextHandler, ContextT,
                                                   Render (..),
                                                   liftNonWinContextIO)

{- Some wording & structure:

    Shader (with a majuscule) = "GPipeShader" => [(OpenGL program made of OpenGL shaders, condition)]

    When a Shader is compiled, it means that it is translated into OpenGL shader
    sources (with a context) which are compiled then linked in programs when
    wrapped into a rendering action which select the appropriate shader at
    runtime.
-}

-- More a "GPipeShaderEnvironmentContextConnector".
data ShaderState s = ShaderState
    Int -- Next name.
    (RenderIOState s)

newShaderState :: ShaderState s
newShaderState :: ShaderState s
newShaderState = Int -> RenderIOState s -> ShaderState s
forall s. Int -> RenderIOState s -> ShaderState s
ShaderState Int
1 RenderIOState s
forall s. RenderIOState s
newRenderIOState

{-
I'm not a big fan of the ShaderM monad, because its important part is its side
effects. A the end of the day, we always end up with a ShaderM os () and are
only interested in the 'told' drawcalls with the 'put' ShaderState. When a
ShaderM is not returning a () value, there are no drawcall (yet), the returned
value is mostly a work in progress constructed and the context of the ShaderM is
not really used (WriterT is not used in any cases). I'm probably talking outside
my level of profiency here, but I suspect it would have been cleaner & clearer
to separate the WriterT.
-}
newtype ShaderM s a = ShaderM
    (ReaderT
        UniformAlignment -- Meant to be retrieved using askUniformAlignment.
        (WriterT
            (   [IO (Drawcall s)] -- Produce a list of drawcalls (the IO is only here for SNMap)
            ,   s -> All -- Condition to execute the drawcalls (need to be a monoid such as the tuple could be too).
            )
            (ListT -- Needed to automatically derive MonadPlus and Application, but what else?
                (State
                    (ShaderState s)
                )
            )
        )
        a
    )
    deriving (Monad (ShaderM s)
Alternative (ShaderM s)
ShaderM s a
Alternative (ShaderM s)
-> Monad (ShaderM s)
-> (forall a. ShaderM s a)
-> (forall a. ShaderM s a -> ShaderM s a -> ShaderM s a)
-> MonadPlus (ShaderM s)
ShaderM s a -> ShaderM s a -> ShaderM s a
forall s. Monad (ShaderM s)
forall s. Alternative (ShaderM s)
forall a. ShaderM s a
forall a. ShaderM s a -> ShaderM s a -> ShaderM s a
forall s a. ShaderM s a
forall s a. ShaderM s a -> ShaderM s a -> ShaderM s a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: ShaderM s a -> ShaderM s a -> ShaderM s a
$cmplus :: forall s a. ShaderM s a -> ShaderM s a -> ShaderM s a
mzero :: ShaderM s a
$cmzero :: forall s a. ShaderM s a
$cp2MonadPlus :: forall s. Monad (ShaderM s)
$cp1MonadPlus :: forall s. Alternative (ShaderM s)
MonadPlus, Applicative (ShaderM s)
a -> ShaderM s a
Applicative (ShaderM s)
-> (forall a b. ShaderM s a -> (a -> ShaderM s b) -> ShaderM s b)
-> (forall a b. ShaderM s a -> ShaderM s b -> ShaderM s b)
-> (forall a. a -> ShaderM s a)
-> Monad (ShaderM s)
ShaderM s a -> (a -> ShaderM s b) -> ShaderM s b
ShaderM s a -> ShaderM s b -> ShaderM s b
forall s. Applicative (ShaderM s)
forall a. a -> ShaderM s a
forall s a. a -> ShaderM s a
forall a b. ShaderM s a -> ShaderM s b -> ShaderM s b
forall a b. ShaderM s a -> (a -> ShaderM s b) -> ShaderM s b
forall s a b. ShaderM s a -> ShaderM s b -> ShaderM s b
forall s a b. ShaderM s a -> (a -> ShaderM s b) -> ShaderM s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ShaderM s a
$creturn :: forall s a. a -> ShaderM s a
>> :: ShaderM s a -> ShaderM s b -> ShaderM s b
$c>> :: forall s a b. ShaderM s a -> ShaderM s b -> ShaderM s b
>>= :: ShaderM s a -> (a -> ShaderM s b) -> ShaderM s b
$c>>= :: forall s a b. ShaderM s a -> (a -> ShaderM s b) -> ShaderM s b
$cp1Monad :: forall s. Applicative (ShaderM s)
Monad, Applicative (ShaderM s)
ShaderM s a
Applicative (ShaderM s)
-> (forall a. ShaderM s a)
-> (forall a. ShaderM s a -> ShaderM s a -> ShaderM s a)
-> (forall a. ShaderM s a -> ShaderM s [a])
-> (forall a. ShaderM s a -> ShaderM s [a])
-> Alternative (ShaderM s)
ShaderM s a -> ShaderM s a -> ShaderM s a
ShaderM s a -> ShaderM s [a]
ShaderM s a -> ShaderM s [a]
forall s. Applicative (ShaderM s)
forall a. ShaderM s a
forall a. ShaderM s a -> ShaderM s [a]
forall a. ShaderM s a -> ShaderM s a -> ShaderM s a
forall s a. ShaderM s a
forall s a. ShaderM s a -> ShaderM s [a]
forall s a. ShaderM s a -> ShaderM s a -> ShaderM s a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: ShaderM s a -> ShaderM s [a]
$cmany :: forall s a. ShaderM s a -> ShaderM s [a]
some :: ShaderM s a -> ShaderM s [a]
$csome :: forall s a. ShaderM s a -> ShaderM s [a]
<|> :: ShaderM s a -> ShaderM s a -> ShaderM s a
$c<|> :: forall s a. ShaderM s a -> ShaderM s a -> ShaderM s a
empty :: ShaderM s a
$cempty :: forall s a. ShaderM s a
$cp1Alternative :: forall s. Applicative (ShaderM s)
Alternative, Functor (ShaderM s)
a -> ShaderM s a
Functor (ShaderM s)
-> (forall a. a -> ShaderM s a)
-> (forall a b. ShaderM s (a -> b) -> ShaderM s a -> ShaderM s b)
-> (forall a b c.
    (a -> b -> c) -> ShaderM s a -> ShaderM s b -> ShaderM s c)
-> (forall a b. ShaderM s a -> ShaderM s b -> ShaderM s b)
-> (forall a b. ShaderM s a -> ShaderM s b -> ShaderM s a)
-> Applicative (ShaderM s)
ShaderM s a -> ShaderM s b -> ShaderM s b
ShaderM s a -> ShaderM s b -> ShaderM s a
ShaderM s (a -> b) -> ShaderM s a -> ShaderM s b
(a -> b -> c) -> ShaderM s a -> ShaderM s b -> ShaderM s c
forall s. Functor (ShaderM s)
forall a. a -> ShaderM s a
forall s a. a -> ShaderM s a
forall a b. ShaderM s a -> ShaderM s b -> ShaderM s a
forall a b. ShaderM s a -> ShaderM s b -> ShaderM s b
forall a b. ShaderM s (a -> b) -> ShaderM s a -> ShaderM s b
forall s a b. ShaderM s a -> ShaderM s b -> ShaderM s a
forall s a b. ShaderM s a -> ShaderM s b -> ShaderM s b
forall s a b. ShaderM s (a -> b) -> ShaderM s a -> ShaderM s b
forall a b c.
(a -> b -> c) -> ShaderM s a -> ShaderM s b -> ShaderM s c
forall s a b c.
(a -> b -> c) -> ShaderM s a -> ShaderM s b -> ShaderM s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ShaderM s a -> ShaderM s b -> ShaderM s a
$c<* :: forall s a b. ShaderM s a -> ShaderM s b -> ShaderM s a
*> :: ShaderM s a -> ShaderM s b -> ShaderM s b
$c*> :: forall s a b. ShaderM s a -> ShaderM s b -> ShaderM s b
liftA2 :: (a -> b -> c) -> ShaderM s a -> ShaderM s b -> ShaderM s c
$cliftA2 :: forall s a b c.
(a -> b -> c) -> ShaderM s a -> ShaderM s b -> ShaderM s c
<*> :: ShaderM s (a -> b) -> ShaderM s a -> ShaderM s b
$c<*> :: forall s a b. ShaderM s (a -> b) -> ShaderM s a -> ShaderM s b
pure :: a -> ShaderM s a
$cpure :: forall s a. a -> ShaderM s a
$cp1Applicative :: forall s. Functor (ShaderM s)
Applicative, a -> ShaderM s b -> ShaderM s a
(a -> b) -> ShaderM s a -> ShaderM s b
(forall a b. (a -> b) -> ShaderM s a -> ShaderM s b)
-> (forall a b. a -> ShaderM s b -> ShaderM s a)
-> Functor (ShaderM s)
forall a b. a -> ShaderM s b -> ShaderM s a
forall a b. (a -> b) -> ShaderM s a -> ShaderM s b
forall s a b. a -> ShaderM s b -> ShaderM s a
forall s a b. (a -> b) -> ShaderM s a -> ShaderM s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ShaderM s b -> ShaderM s a
$c<$ :: forall s a b. a -> ShaderM s b -> ShaderM s a
fmap :: (a -> b) -> ShaderM s a -> ShaderM s b
$cfmap :: forall s a b. (a -> b) -> ShaderM s a -> ShaderM s b
Functor)

-- Return a new name to be used as a key in RenderIOState. for a program,
-- shader, uniform, texture unit (sampler)… or something not related to a named
-- OpenGL object.
getNewName :: ShaderM s Int
getNewName :: ShaderM s Int
getNewName = do
    ShaderState Int
n RenderIOState s
r <- ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  (ShaderState s)
-> ShaderM s (ShaderState s)
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM (ReaderT
   Int
   (WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
   (ShaderState s)
 -> ShaderM s (ShaderState s))
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     (ShaderState s)
-> ShaderM s (ShaderState s)
forall a b. (a -> b) -> a -> b
$ WriterT
  ([IO (Drawcall s)], s -> All)
  (ListT (State (ShaderState s)))
  (ShaderState s)
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     (ShaderState s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   ([IO (Drawcall s)], s -> All)
   (ListT (State (ShaderState s)))
   (ShaderState s)
 -> ReaderT
      Int
      (WriterT
         ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
      (ShaderState s))
-> WriterT
     ([IO (Drawcall s)], s -> All)
     (ListT (State (ShaderState s)))
     (ShaderState s)
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     (ShaderState s)
forall a b. (a -> b) -> a -> b
$ ListT (State (ShaderState s)) (ShaderState s)
-> WriterT
     ([IO (Drawcall s)], s -> All)
     (ListT (State (ShaderState s)))
     (ShaderState s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ListT (State (ShaderState s)) (ShaderState s)
 -> WriterT
      ([IO (Drawcall s)], s -> All)
      (ListT (State (ShaderState s)))
      (ShaderState s))
-> ListT (State (ShaderState s)) (ShaderState s)
-> WriterT
     ([IO (Drawcall s)], s -> All)
     (ListT (State (ShaderState s)))
     (ShaderState s)
forall a b. (a -> b) -> a -> b
$ StateT (ShaderState s) Identity (ShaderState s)
-> ListT (State (ShaderState s)) (ShaderState s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (ShaderState s) Identity (ShaderState s)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  ()
-> ShaderM s ()
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM (ReaderT
   Int
   (WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
   ()
 -> ShaderM s ())
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
-> ShaderM s ()
forall a b. (a -> b) -> a -> b
$ WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
 -> ReaderT
      Int
      (WriterT
         ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
      ())
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall a b. (a -> b) -> a -> b
$ ListT (State (ShaderState s)) ()
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ListT (State (ShaderState s)) ()
 -> WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ())
-> ListT (State (ShaderState s)) ()
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
forall a b. (a -> b) -> a -> b
$ StateT (ShaderState s) Identity ()
-> ListT (State (ShaderState s)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (ShaderState s) Identity ()
 -> ListT (State (ShaderState s)) ())
-> StateT (ShaderState s) Identity ()
-> ListT (State (ShaderState s)) ()
forall a b. (a -> b) -> a -> b
$ ShaderState s -> StateT (ShaderState s) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ShaderState s -> StateT (ShaderState s) Identity ())
-> ShaderState s -> StateT (ShaderState s) Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> RenderIOState s -> ShaderState s
forall s. Int -> RenderIOState s -> ShaderState s
ShaderState (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) RenderIOState s
r
    Int -> ShaderM s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

askUniformAlignment :: ShaderM s UniformAlignment
askUniformAlignment :: ShaderM s Int
askUniformAlignment = ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  Int
-> ShaderM s Int
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  Int
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

modifyRenderIO :: (RenderIOState s -> RenderIOState s) -> ShaderM s ()
modifyRenderIO :: (RenderIOState s -> RenderIOState s) -> ShaderM s ()
modifyRenderIO RenderIOState s -> RenderIOState s
f = ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  ()
-> ShaderM s ()
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM (ReaderT
   Int
   (WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
   ()
 -> ShaderM s ())
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
-> ShaderM s ()
forall a b. (a -> b) -> a -> b
$ WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
 -> ReaderT
      Int
      (WriterT
         ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
      ())
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall a b. (a -> b) -> a -> b
$ ListT (State (ShaderState s)) ()
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ListT (State (ShaderState s)) ()
 -> WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ())
-> ListT (State (ShaderState s)) ()
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
forall a b. (a -> b) -> a -> b
$ StateT (ShaderState s) Identity ()
-> ListT (State (ShaderState s)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (ShaderState s) Identity ()
 -> ListT (State (ShaderState s)) ())
-> StateT (ShaderState s) Identity ()
-> ListT (State (ShaderState s)) ()
forall a b. (a -> b) -> a -> b
$ (ShaderState s -> ShaderState s)
-> StateT (ShaderState s) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\(ShaderState Int
a RenderIOState s
s) -> Int -> RenderIOState s -> ShaderState s
forall s. Int -> RenderIOState s -> ShaderState s
ShaderState Int
a (RenderIOState s -> RenderIOState s
f RenderIOState s
s))

tellDrawcall :: IO (Drawcall s) -> ShaderM s ()
tellDrawcall :: IO (Drawcall s) -> ShaderM s ()
tellDrawcall IO (Drawcall s)
drawcall = ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  ()
-> ShaderM s ()
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM (ReaderT
   Int
   (WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
   ()
 -> ShaderM s ())
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
-> ShaderM s ()
forall a b. (a -> b) -> a -> b
$ WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
 -> ReaderT
      Int
      (WriterT
         ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
      ())
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall a b. (a -> b) -> a -> b
$ ([IO (Drawcall s)], s -> All)
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell ([IO (Drawcall s)
drawcall], s -> All
forall a. Monoid a => a
mempty)

-- | The monad in which all GPU computations are done. 'Shader os s a' lives in
-- an object space 'os' and a context with format 'f', closing over an
-- environent of type 's'.
newtype Shader os s a = Shader (ShaderM s a)
    deriving (Monad (Shader os s)
Alternative (Shader os s)
Shader os s a
Alternative (Shader os s)
-> Monad (Shader os s)
-> (forall a. Shader os s a)
-> (forall a. Shader os s a -> Shader os s a -> Shader os s a)
-> MonadPlus (Shader os s)
Shader os s a -> Shader os s a -> Shader os s a
forall a. Shader os s a
forall a. Shader os s a -> Shader os s a -> Shader os s a
forall os s. Monad (Shader os s)
forall os s. Alternative (Shader os s)
forall os s a. Shader os s a
forall os s a. Shader os s a -> Shader os s a -> Shader os s a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: Shader os s a -> Shader os s a -> Shader os s a
$cmplus :: forall os s a. Shader os s a -> Shader os s a -> Shader os s a
mzero :: Shader os s a
$cmzero :: forall os s a. Shader os s a
$cp2MonadPlus :: forall os s. Monad (Shader os s)
$cp1MonadPlus :: forall os s. Alternative (Shader os s)
MonadPlus, Applicative (Shader os s)
a -> Shader os s a
Applicative (Shader os s)
-> (forall a b.
    Shader os s a -> (a -> Shader os s b) -> Shader os s b)
-> (forall a b. Shader os s a -> Shader os s b -> Shader os s b)
-> (forall a. a -> Shader os s a)
-> Monad (Shader os s)
Shader os s a -> (a -> Shader os s b) -> Shader os s b
Shader os s a -> Shader os s b -> Shader os s b
forall a. a -> Shader os s a
forall os s. Applicative (Shader os s)
forall a b. Shader os s a -> Shader os s b -> Shader os s b
forall a b. Shader os s a -> (a -> Shader os s b) -> Shader os s b
forall os s a. a -> Shader os s a
forall os s a b. Shader os s a -> Shader os s b -> Shader os s b
forall os s a b.
Shader os s a -> (a -> Shader os s b) -> Shader os s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Shader os s a
$creturn :: forall os s a. a -> Shader os s a
>> :: Shader os s a -> Shader os s b -> Shader os s b
$c>> :: forall os s a b. Shader os s a -> Shader os s b -> Shader os s b
>>= :: Shader os s a -> (a -> Shader os s b) -> Shader os s b
$c>>= :: forall os s a b.
Shader os s a -> (a -> Shader os s b) -> Shader os s b
$cp1Monad :: forall os s. Applicative (Shader os s)
Monad, Applicative (Shader os s)
Shader os s a
Applicative (Shader os s)
-> (forall a. Shader os s a)
-> (forall a. Shader os s a -> Shader os s a -> Shader os s a)
-> (forall a. Shader os s a -> Shader os s [a])
-> (forall a. Shader os s a -> Shader os s [a])
-> Alternative (Shader os s)
Shader os s a -> Shader os s a -> Shader os s a
Shader os s a -> Shader os s [a]
Shader os s a -> Shader os s [a]
forall a. Shader os s a
forall a. Shader os s a -> Shader os s [a]
forall a. Shader os s a -> Shader os s a -> Shader os s a
forall os s. Applicative (Shader os s)
forall os s a. Shader os s a
forall os s a. Shader os s a -> Shader os s [a]
forall os s a. Shader os s a -> Shader os s a -> Shader os s a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: Shader os s a -> Shader os s [a]
$cmany :: forall os s a. Shader os s a -> Shader os s [a]
some :: Shader os s a -> Shader os s [a]
$csome :: forall os s a. Shader os s a -> Shader os s [a]
<|> :: Shader os s a -> Shader os s a -> Shader os s a
$c<|> :: forall os s a. Shader os s a -> Shader os s a -> Shader os s a
empty :: Shader os s a
$cempty :: forall os s a. Shader os s a
$cp1Alternative :: forall os s. Applicative (Shader os s)
Alternative, Functor (Shader os s)
a -> Shader os s a
Functor (Shader os s)
-> (forall a. a -> Shader os s a)
-> (forall a b.
    Shader os s (a -> b) -> Shader os s a -> Shader os s b)
-> (forall a b c.
    (a -> b -> c) -> Shader os s a -> Shader os s b -> Shader os s c)
-> (forall a b. Shader os s a -> Shader os s b -> Shader os s b)
-> (forall a b. Shader os s a -> Shader os s b -> Shader os s a)
-> Applicative (Shader os s)
Shader os s a -> Shader os s b -> Shader os s b
Shader os s a -> Shader os s b -> Shader os s a
Shader os s (a -> b) -> Shader os s a -> Shader os s b
(a -> b -> c) -> Shader os s a -> Shader os s b -> Shader os s c
forall a. a -> Shader os s a
forall os s. Functor (Shader os s)
forall a b. Shader os s a -> Shader os s b -> Shader os s a
forall a b. Shader os s a -> Shader os s b -> Shader os s b
forall a b. Shader os s (a -> b) -> Shader os s a -> Shader os s b
forall os s a. a -> Shader os s a
forall a b c.
(a -> b -> c) -> Shader os s a -> Shader os s b -> Shader os s c
forall os s a b. Shader os s a -> Shader os s b -> Shader os s a
forall os s a b. Shader os s a -> Shader os s b -> Shader os s b
forall os s a b.
Shader os s (a -> b) -> Shader os s a -> Shader os s b
forall os s a b c.
(a -> b -> c) -> Shader os s a -> Shader os s b -> Shader os s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Shader os s a -> Shader os s b -> Shader os s a
$c<* :: forall os s a b. Shader os s a -> Shader os s b -> Shader os s a
*> :: Shader os s a -> Shader os s b -> Shader os s b
$c*> :: forall os s a b. Shader os s a -> Shader os s b -> Shader os s b
liftA2 :: (a -> b -> c) -> Shader os s a -> Shader os s b -> Shader os s c
$cliftA2 :: forall os s a b c.
(a -> b -> c) -> Shader os s a -> Shader os s b -> Shader os s c
<*> :: Shader os s (a -> b) -> Shader os s a -> Shader os s b
$c<*> :: forall os s a b.
Shader os s (a -> b) -> Shader os s a -> Shader os s b
pure :: a -> Shader os s a
$cpure :: forall os s a. a -> Shader os s a
$cp1Applicative :: forall os s. Functor (Shader os s)
Applicative, a -> Shader os s b -> Shader os s a
(a -> b) -> Shader os s a -> Shader os s b
(forall a b. (a -> b) -> Shader os s a -> Shader os s b)
-> (forall a b. a -> Shader os s b -> Shader os s a)
-> Functor (Shader os s)
forall a b. a -> Shader os s b -> Shader os s a
forall a b. (a -> b) -> Shader os s a -> Shader os s b
forall os s a b. a -> Shader os s b -> Shader os s a
forall os s a b. (a -> b) -> Shader os s a -> Shader os s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Shader os s b -> Shader os s a
$c<$ :: forall os s a b. a -> Shader os s b -> Shader os s a
fmap :: (a -> b) -> Shader os s a -> Shader os s b
$cfmap :: forall os s a b. (a -> b) -> Shader os s a -> Shader os s b
Functor)

-- | Map the environment to a different environment and run a Shader in that sub
-- environment, returning it's result.
mapShader :: (s -> s') -> Shader os s' a -> Shader os s a
mapShader :: (s -> s') -> Shader os s' a -> Shader os s a
mapShader s -> s'
f (Shader (ShaderM ReaderT
  Int
  (WriterT
     ([IO (Drawcall s')], s' -> All) (ListT (State (ShaderState s'))))
  a
m)) = ShaderM s a -> Shader os s a
forall os s a. ShaderM s a -> Shader os s a
Shader (ShaderM s a -> Shader os s a) -> ShaderM s a -> Shader os s a
forall a b. (a -> b) -> a -> b
$ ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM (ReaderT
   Int
   (WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
   a
 -> ShaderM s a)
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     a
-> ShaderM s a
forall a b. (a -> b) -> a -> b
$ do
    Int
uniAl <- ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  Int
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
 -> ReaderT
      Int
      (WriterT
         ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
      a)
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     a
forall a b. (a -> b) -> a -> b
$ ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
 -> WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a)
-> ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
forall a b. (a -> b) -> a -> b
$ StateT
  (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
-> ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (StateT
   (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
 -> ListT
      (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All)))
-> StateT
     (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
-> ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
forall a b. (a -> b) -> a -> b
$ do
        ShaderState Int
x RenderIOState s
s <- StateT (ShaderState s) Identity (ShaderState s)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        let ([(a, ([IO (Drawcall s')], s' -> All))]
conditionalDrawcalls, ShaderState Int
x' RenderIOState s'
s') = State (ShaderState s') [(a, ([IO (Drawcall s')], s' -> All))]
-> ShaderState s'
-> ([(a, ([IO (Drawcall s')], s' -> All))], ShaderState s')
forall s a. State s a -> s -> (a, s)
runState (ListT (State (ShaderState s')) (a, ([IO (Drawcall s')], s' -> All))
-> State (ShaderState s') [(a, ([IO (Drawcall s')], s' -> All))]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (WriterT
  ([IO (Drawcall s')], s' -> All) (ListT (State (ShaderState s'))) a
-> ListT
     (State (ShaderState s')) (a, ([IO (Drawcall s')], s' -> All))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (ReaderT
  Int
  (WriterT
     ([IO (Drawcall s')], s' -> All) (ListT (State (ShaderState s'))))
  a
-> Int
-> WriterT
     ([IO (Drawcall s')], s' -> All) (ListT (State (ShaderState s'))) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  Int
  (WriterT
     ([IO (Drawcall s')], s' -> All) (ListT (State (ShaderState s'))))
  a
m Int
uniAl))) (Int -> RenderIOState s' -> ShaderState s'
forall s. Int -> RenderIOState s -> ShaderState s
ShaderState Int
x RenderIOState s'
forall s. RenderIOState s
newRenderIOState)
        ShaderState s -> StateT (ShaderState s) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ShaderState s -> StateT (ShaderState s) Identity ())
-> ShaderState s -> StateT (ShaderState s) Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> RenderIOState s -> ShaderState s
forall s. Int -> RenderIOState s -> ShaderState s
ShaderState Int
x' ((s -> s') -> RenderIOState s' -> RenderIOState s -> RenderIOState s
forall s s'.
(s -> s') -> RenderIOState s' -> RenderIOState s -> RenderIOState s
mapRenderIOState s -> s'
f RenderIOState s'
s' RenderIOState s
s)
        [(a, ([IO (Drawcall s)], s -> All))]
-> StateT
     (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, ([IO (Drawcall s)], s -> All))]
 -> StateT
      (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))])
-> [(a, ([IO (Drawcall s)], s -> All))]
-> StateT
     (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
forall a b. (a -> b) -> a -> b
$ ((a, ([IO (Drawcall s')], s' -> All))
 -> (a, ([IO (Drawcall s)], s -> All)))
-> [(a, ([IO (Drawcall s')], s' -> All))]
-> [(a, ([IO (Drawcall s)], s -> All))]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
a, ([IO (Drawcall s')]
drawcalls, s' -> All
test)) -> (a
a, ((IO (Drawcall s') -> IO (Drawcall s))
-> [IO (Drawcall s')] -> [IO (Drawcall s)]
forall a b. (a -> b) -> [a] -> [b]
map (IO (Drawcall s')
-> (Drawcall s' -> IO (Drawcall s)) -> IO (Drawcall s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Drawcall s -> IO (Drawcall s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Drawcall s -> IO (Drawcall s))
-> (Drawcall s' -> Drawcall s) -> Drawcall s' -> IO (Drawcall s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s') -> Drawcall s' -> Drawcall s
forall s s'. (s -> s') -> Drawcall s' -> Drawcall s
mapDrawcall s -> s'
f)) [IO (Drawcall s')]
drawcalls, s' -> All
test (s' -> All) -> (s -> s') -> s -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s'
f))) [(a, ([IO (Drawcall s')], s' -> All))]
conditionalDrawcalls

-- | Conditionally run the effects of a shader when a 'Maybe' value is 'Just'
-- something.
maybeShader :: (s -> Maybe s') -> Shader os s' () -> Shader os s ()
maybeShader :: (s -> Maybe s') -> Shader os s' () -> Shader os s ()
maybeShader s -> Maybe s'
f Shader os s' ()
m = ((s -> Bool) -> Shader os s ()
forall s os. (s -> Bool) -> Shader os s ()
guard' (Maybe s' -> Bool
forall a. Maybe a -> Bool
isJust (Maybe s' -> Bool) -> (s -> Maybe s') -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Maybe s'
f) Shader os s () -> Shader os s () -> Shader os s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (s -> s') -> Shader os s' () -> Shader os s ()
forall s s' os a. (s -> s') -> Shader os s' a -> Shader os s a
mapShader (Maybe s' -> s'
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe s' -> s') -> (s -> Maybe s') -> s -> s'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Maybe s'
f) Shader os s' ()
m) Shader os s () -> Shader os s () -> Shader os s ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (s -> Bool) -> Shader os s ()
forall s os. (s -> Bool) -> Shader os s ()
guard' (Maybe s' -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe s' -> Bool) -> (s -> Maybe s') -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Maybe s'
f)

-- | Select one of two 'Shader' actions based on whether an 'Either' value is
-- 'Left' or 'Right'.
chooseShader :: (s -> Either s' s'') -> Shader os s' a -> Shader os s'' a -> Shader os s a
chooseShader :: (s -> Either s' s'')
-> Shader os s' a -> Shader os s'' a -> Shader os s a
chooseShader s -> Either s' s''
f Shader os s' a
a Shader os s'' a
b = ((s -> Bool) -> Shader os s ()
forall s os. (s -> Bool) -> Shader os s ()
guard' (Either s' s'' -> Bool
forall a b. Either a b -> Bool
isLeft (Either s' s'' -> Bool) -> (s -> Either s' s'') -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either s' s''
f) Shader os s () -> Shader os s a -> Shader os s a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (s -> s') -> Shader os s' a -> Shader os s a
forall s s' os a. (s -> s') -> Shader os s' a -> Shader os s a
mapShader (Either s' s'' -> s'
forall a b. Either a b -> a
fromLeft (Either s' s'' -> s') -> (s -> Either s' s'') -> s -> s'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either s' s''
f) Shader os s' a
a) Shader os s a -> Shader os s a -> Shader os s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((s -> Bool) -> Shader os s ()
forall s os. (s -> Bool) -> Shader os s ()
guard' (Either s' s'' -> Bool
forall a b. Either a b -> Bool
isRight (Either s' s'' -> Bool) -> (s -> Either s' s'') -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either s' s''
f) Shader os s () -> Shader os s a -> Shader os s a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (s -> s'') -> Shader os s'' a -> Shader os s a
forall s s' os a. (s -> s') -> Shader os s' a -> Shader os s a
mapShader (Either s' s'' -> s''
forall a b. Either a b -> b
fromRight (Either s' s'' -> s'') -> (s -> Either s' s'') -> s -> s''
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either s' s''
f) Shader os s'' a
b) where
    fromLeft :: Either a b -> a
fromLeft (Left a
x) = a
x
    fromRight :: Either a b -> b
fromRight (Right b
x) = b
x

-- | Discard all effects of a 'Shader' action (i.e., dont draw anything) and
-- just return the resulting value.
silenceShader :: Shader os s a -> Shader os s a
silenceShader :: Shader os s a -> Shader os s a
silenceShader (Shader (ShaderM ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
m)) = ShaderM s a -> Shader os s a
forall os s a. ShaderM s a -> Shader os s a
Shader (ShaderM s a -> Shader os s a) -> ShaderM s a -> Shader os s a
forall a b. (a -> b) -> a -> b
$ ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM (ReaderT
   Int
   (WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
   a
 -> ShaderM s a)
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     a
-> ShaderM s a
forall a b. (a -> b) -> a -> b
$ do
    Int
uniAl <- ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  Int
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
 -> ReaderT
      Int
      (WriterT
         ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
      a)
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     a
forall a b. (a -> b) -> a -> b
$ ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
 -> WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a)
-> ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
forall a b. (a -> b) -> a -> b
$ StateT
  (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
-> ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (StateT
   (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
 -> ListT
      (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All)))
-> StateT
     (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
-> ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
forall a b. (a -> b) -> a -> b
$ do
        ShaderState s
s <- StateT (ShaderState s) Identity (ShaderState s)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        let ([(a, ([IO (Drawcall s)], s -> All))]
conditionalDrawcalls, ShaderState s
s') = StateT
  (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
-> ShaderState s
-> ([(a, ([IO (Drawcall s)], s -> All))], ShaderState s)
forall s a. State s a -> s -> (a, s)
runState (ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
-> StateT
     (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
-> ListT (State (ShaderState s)) (a, ([IO (Drawcall s)], s -> All))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> Int
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
m Int
uniAl))) ShaderState s
s
        ShaderState s -> StateT (ShaderState s) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ShaderState s
s'
        [(a, ([IO (Drawcall s)], s -> All))]
-> StateT
     (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, ([IO (Drawcall s)], s -> All))]
 -> StateT
      (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))])
-> [(a, ([IO (Drawcall s)], s -> All))]
-> StateT
     (ShaderState s) Identity [(a, ([IO (Drawcall s)], s -> All))]
forall a b. (a -> b) -> a -> b
$ ((a, ([IO (Drawcall s)], s -> All))
 -> (a, ([IO (Drawcall s)], s -> All)))
-> [(a, ([IO (Drawcall s)], s -> All))]
-> [(a, ([IO (Drawcall s)], s -> All))]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a
a, ([IO (Drawcall s)]
_, s -> All
test)) -> (a
a, ([], s -> All
test))) [(a, ([IO (Drawcall s)], s -> All))]
conditionalDrawcalls

-- | Like 'guard', but dependent on the 'Shaders' environment value. Since this
--   will be evaluated at shader run time, as opposed to shader compile time for
--   'guard', using this to do recursion will make 'compileShader' diverge. You
--   can break that divergence by combining it with a normal 'guard' and a
--   maximum loop count.
guard' :: (s -> Bool) -> Shader os s ()
guard' :: (s -> Bool) -> Shader os s ()
guard' s -> Bool
f = ShaderM s () -> Shader os s ()
forall os s a. ShaderM s a -> Shader os s a
Shader (ShaderM s () -> Shader os s ()) -> ShaderM s () -> Shader os s ()
forall a b. (a -> b) -> a -> b
$ ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  ()
-> ShaderM s ()
forall s a.
ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  a
-> ShaderM s a
ShaderM (ReaderT
   Int
   (WriterT
      ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
   ()
 -> ShaderM s ())
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
-> ShaderM s ()
forall a b. (a -> b) -> a -> b
$ WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
 -> ReaderT
      Int
      (WriterT
         ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
      ())
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ReaderT
     Int
     (WriterT
        ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
     ()
forall a b. (a -> b) -> a -> b
$ ([IO (Drawcall s)], s -> All)
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell ([IO (Drawcall s)]
forall a. Monoid a => a
mempty, Bool -> All
All (Bool -> All) -> (s -> Bool) -> s -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Bool
f)

-- | Compiles a shader into a 'CompiledShader'. This action will usually take a
-- second or more, so put it during a loading sequence or something.
--
-- May throw a 'GPipeException' if the graphics driver doesn't support something
-- in this shader (e.g. too many interpolated floats sent between a vertex and a
-- fragment shader)
compileShader :: (ContextHandler ctx, MonadIO m, MonadException m) => Shader os s () -> ContextT ctx os m (CompiledShader os s)
compileShader :: Shader os s () -> ContextT ctx os m (CompiledShader os s)
compileShader (Shader (ShaderM ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  ()
m)) = do

    Int
uniformAlignment <- IO Int -> ContextT ctx os m Int
forall ctx (m :: * -> *) a os.
(ContextHandler ctx, MonadIO m) =>
IO a -> ContextT ctx os m a
liftNonWinContextIO IO Int
getUniformAlignment
    let ([([IO (Drawcall s)], s -> All)]
conditionalDrawcalls, ShaderState Int
_ RenderIOState s
state) = State (ShaderState s) [([IO (Drawcall s)], s -> All)]
-> ShaderState s
-> ([([IO (Drawcall s)], s -> All)], ShaderState s)
forall s a. State s a -> s -> (a, s)
runState (ListT (State (ShaderState s)) ([IO (Drawcall s)], s -> All)
-> State (ShaderState s) [([IO (Drawcall s)], s -> All)]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (WriterT
  ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
-> ListT (State (ShaderState s)) ([IO (Drawcall s)], s -> All)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  ()
-> Int
-> WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))) ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  Int
  (WriterT
     ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s))))
  ()
m Int
uniformAlignment))) ShaderState s
forall s. ShaderState s
newShaderState
    [(CompiledShader os s, s -> All)]
conditionalRenderers <- [([IO (Drawcall s)], s -> All)]
-> (([IO (Drawcall s)], s -> All)
    -> ContextT ctx os m (CompiledShader os s, s -> All))
-> ContextT ctx os m [(CompiledShader os s, s -> All)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([IO (Drawcall s)], s -> All)]
conditionalDrawcalls ((([IO (Drawcall s)], s -> All)
  -> ContextT ctx os m (CompiledShader os s, s -> All))
 -> ContextT ctx os m [(CompiledShader os s, s -> All)])
-> (([IO (Drawcall s)], s -> All)
    -> ContextT ctx os m (CompiledShader os s, s -> All))
-> ContextT ctx os m [(CompiledShader os s, s -> All)]
forall a b. (a -> b) -> a -> b
$ \ ([IO (Drawcall s)]
drawcalls, s -> All
test) -> do
        CompiledShader os s
renderer <- [IO (Drawcall s)]
-> RenderIOState s -> ContextT ctx os m (CompiledShader os s)
forall (m :: * -> *) ctx s os.
(Monad m, MonadIO m, MonadException m, ContextHandler ctx) =>
[IO (Drawcall s)]
-> RenderIOState s -> ContextT ctx os m (CompiledShader os s)
compileDrawcalls [IO (Drawcall s)]
drawcalls RenderIOState s
state
        (CompiledShader os s, s -> All)
-> ContextT ctx os m (CompiledShader os s, s -> All)
forall (m :: * -> *) a. Monad m => a -> m a
return (CompiledShader os s
renderer, s -> All
test)

    -- Return a wrapping renderer which select the first renderer for the
    -- environment before using it. Remember: renderer <=> CompiledDrawcall <=> CompiledShader
    CompiledShader os s -> ContextT ctx os m (CompiledShader os s)
forall (m :: * -> *) a. Monad m => a -> m a
return (CompiledShader os s -> ContextT ctx os m (CompiledShader os s))
-> CompiledShader os s -> ContextT ctx os m (CompiledShader os s)
forall a b. (a -> b) -> a -> b
$ \ s
environment -> case ((CompiledShader os s, s -> All) -> Bool)
-> [(CompiledShader os s, s -> All)]
-> Maybe (CompiledShader os s, s -> All)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ (CompiledShader os s
_, s -> All
test) -> All -> Bool
getAll (s -> All
test s
environment)) [(CompiledShader os s, s -> All)]
conditionalRenderers of
        Maybe (CompiledShader os s, s -> All)
Nothing -> [Char] -> Render os ()
forall a. HasCallStack => [Char] -> a
error [Char]
"render: Shader evaluated to mzero (no Shader selected)"
        Just (CompiledShader os s
renderer, s -> All
_) -> CompiledShader os s
renderer s
environment