never executed always true always false
    1 {-|
    2 Module: Flaw.Graphics
    3 Description: Graphics abstraction.
    4 License: MIT
    5 
    6 Graphics system is mostly abstracted from backend. Almost everything from
    7 uploading textures to writing shader programs can be done with zero amount
    8 of backend-dependent code.
    9 
   10 Initialization of graphics subsystem is still backend-dependent though.
   11 Initialization includes creating instances of 'System', 'Device' and 'Presenter'
   12 classes.
   13 
   14 * 'System' instance allows to enumerate graphics hardware supported by backend,
   15 get information about displays and display modes.
   16 
   17 * 'Device' instance creates graphics resources such as render targets, textures,
   18 shader programs, etc.
   19 
   20 * 'Context' instance performs actual drawing. Draw operations run in 'Render' monad.
   21 
   22 * 'Presenter' instance shows rendering results onto screen or window.
   23 
   24 Abstraction is mostly follows DirectX 11 / OpenGL 3 model.
   25 In a few places the lowest common denominator was choosen for certain features,
   26 to allow one-to-one mapping from abstraction to implementation. Examples:
   27 
   28 * Textures accept default sampling parameters, used when no sampler is bound;
   29 
   30 * Program objects are created explicitly;
   31 
   32 * There's no separate texture and sampler slots. Both a texture and a sampler are bound
   33 into combined slot indexed by numeric index;
   34 
   35 * Default framebuffer is bound automatically as part of initial state inside 'present'.
   36 
   37 -}
   38 
   39 {-# LANGUAGE DeriveGeneric, FlexibleContexts, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TypeFamilies #-}
   40 
   41 module Flaw.Graphics
   42   ( System(..)
   43   , Device(..)
   44   , Context(..)
   45   , Presenter(..)
   46   , DeviceInfo(..)
   47   , DisplayInfo(..)
   48   , DisplayModeInfo(..)
   49   , IndexTopology(..)
   50   , IndexStride(..)
   51   , DepthTestFunc(..)
   52   , Render
   53   , renderScope
   54   , renderFrameBuffer
   55   , renderViewport
   56   , renderGetViewport
   57   , renderScissor
   58   , renderGetScissor
   59   , renderIntersectScissor
   60   , renderVertexBuffer
   61   , renderIndexBuffer
   62   , renderUniformBuffer
   63   , renderSampler
   64   , renderBlendState
   65   , renderDepthTestFunc
   66   , renderDepthWrite
   67   , renderProgram
   68   , renderClearColor
   69   , renderClearDepth
   70   , renderClearStencil
   71   , renderClearDepthStencil
   72   , renderUploadUniformBuffer
   73   , renderUploadVertexBuffer
   74   , renderDraw
   75   , renderDrawInstanced
   76   , renderPlay
   77   , render
   78   , present
   79   ) where
   80 
   81 import Control.Exception
   82 import Control.Monad.Trans.Class
   83 import Control.Monad.Trans.Reader
   84 import qualified Data.ByteString as B
   85 import qualified Data.Serialize as S
   86 import qualified Data.Text as T
   87 import GHC.Generics(Generic)
   88 
   89 import Flaw.Exception
   90 import Flaw.Graphics.Blend
   91 import Flaw.Graphics.Program.Internal
   92 import Flaw.Graphics.Sampler
   93 import Flaw.Graphics.Texture
   94 import Flaw.Math
   95 import Flaw.Stack
   96 
   97 -- | Class of graphics system.
   98 {- Initialization of graphics system is backend-dependent.
   99 There're just a few general functions.
  100 -}
  101 class System s where
  102   -- | Type for id of graphics device.
  103   data DeviceId s :: *
  104   -- | Type for id of display.
  105   data DisplayId s :: *
  106   -- | Type for id of display mode.
  107   data DisplayModeId s :: *
  108   -- | Get list of graphics devices installed in system.
  109   getInstalledDevices :: s -> IO ([(DeviceId s, DeviceInfo s)], IO ())
  110   -- | Create custom display mode (with specified width and height) for specified display.
  111   createDisplayMode
  112     :: s
  113     -> DisplayId s -- ^ Display id.
  114     -> Int -- ^ Width.
  115     -> Int -- ^ Height.
  116     -> IO ((DisplayModeId s, DisplayModeInfo), IO ())
  117 
  118 -- | Class of graphics device.
  119 -- Graphics device performs managing of resources.
  120 -- Also it works as a primary context for the device.
  121 class Device d where
  122   -- | Type for deferred contexts.
  123   type DeferredContext d :: *
  124   -- | Type for texture id.
  125   data TextureId d :: *
  126   -- | Type for sampler state id.
  127   data SamplerStateId d :: *
  128   -- | Type for blend state id.
  129   data BlendStateId d :: *
  130   -- | Type for render target id.
  131   data RenderTargetId d :: *
  132   -- | Type for depth stencil target id.
  133   data DepthStencilTargetId d :: *
  134   -- | Type for framebuffer id.
  135   data FrameBufferId d :: *
  136   -- | Type for vertex buffer id.
  137   data VertexBufferId d :: *
  138   -- | Type for index buffer id.
  139   data IndexBufferId d :: *
  140   -- | Type for program id.
  141   data ProgramId d :: *
  142   -- | Type for uniform buffer id.
  143   data UniformBufferId d :: *
  144 
  145   -- | Null texture.
  146   nullTexture :: TextureId d
  147   -- | Null sampler state.
  148   nullSamplerState :: SamplerStateId d
  149   -- | Null blend state.
  150   nullBlendState :: BlendStateId d
  151   -- | Null depth stencil target.
  152   nullDepthStencilTarget :: DepthStencilTargetId d
  153   -- | Null vertex buffer.
  154   nullVertexBuffer :: VertexBufferId d
  155   -- | Null index buffer.
  156   nullIndexBuffer :: IndexBufferId d
  157   -- | Null uniform buffer.
  158   nullUniformBuffer :: UniformBufferId d
  159 
  160   -- | Create deferred context.
  161   createDeferredContext :: d -> IO (DeferredContext d, IO ())
  162   createDeferredContext _ = throwIO $ DescribeFirstException "creating deferred context is not supported"
  163   -- | Create static texture.
  164   createStaticTexture :: d -> TextureInfo -> SamplerStateInfo -> B.ByteString -> IO (TextureId d, IO ())
  165   -- | Create texture from image packed in any format natively supported by device.
  166   createNativeTexture :: d -> SamplerStateInfo -> B.ByteString -> IO (TextureId d, IO ())
  167   createNativeTexture _ _ _ = throwIO $ DescribeFirstException "creating native texture is not supported"
  168   -- | Create sampler state.
  169   createSamplerState :: d -> SamplerStateInfo -> IO (SamplerStateId d, IO ())
  170   -- | Create blend state.
  171   createBlendState :: d -> BlendStateInfo -> IO (BlendStateId d, IO ())
  172   -- | Create readable render target.
  173   createReadableRenderTarget :: d -> Int -> Int -> TextureFormat -> SamplerStateInfo -> IO ((RenderTargetId d, TextureId d), IO ())
  174   -- | Create depth stencil target.
  175   createDepthStencilTarget :: d -> Int -> Int -> IO (DepthStencilTargetId d, IO ())
  176   -- | Create readable depth stencil target.
  177   createReadableDepthStencilTarget :: d -> Int -> Int -> SamplerStateInfo -> IO ((DepthStencilTargetId d, TextureId d), IO ())
  178   -- | Create framebuffer.
  179   createFrameBuffer :: d -> [RenderTargetId d] -> DepthStencilTargetId d -> IO (FrameBufferId d, IO ())
  180   -- | Create static vertex buffer.
  181   createStaticVertexBuffer
  182     :: d -- ^ Device.
  183     -> B.ByteString -- ^ Buffer.
  184     -> Int -- ^ Stride in bytes.
  185     -> IO (VertexBufferId d, IO ())
  186   -- | Create dynamic vertex buffer.
  187   createDynamicVertexBuffer
  188     :: d -- ^ Device.
  189     -> Int -- ^ Size in bytes.
  190     -> Int -- ^ Stride in bytes.
  191     -> IO (VertexBufferId d, IO ())
  192   -- | Create index buffer.
  193   createStaticIndexBuffer :: d -> B.ByteString -> IndexTopology -> IndexStride -> IO (IndexBufferId d, IO ())
  194   -- | Create program.
  195   createProgram
  196     :: d -- ^ Device.
  197     -> Program () -- ^ Program contents.
  198     -> IO (ProgramId d, IO ())
  199   -- | Create uniform buffer.
  200   createUniformBuffer :: d -> Int -> IO (UniformBufferId d, IO ())
  201 
  202 -- | Class of graphics context.
  203 -- Performs actual render operations.
  204 class Device d => Context c d | c -> d where
  205   ------- Immediate commands.
  206   -- | Clear render target.
  207   contextClearColor :: c -> Int -> Float4 -> IO ()
  208   -- | Clear depth.
  209   contextClearDepth :: c -> Float -> IO ()
  210   -- | Clear stencil.
  211   contextClearStencil :: c -> Int -> IO ()
  212   -- | Clear depth and stencil.
  213   contextClearDepthStencil :: c -> Float -> Int -> IO ()
  214   -- | Upload data to uniform buffer.
  215   contextUploadUniformBuffer :: c -> UniformBufferId d -> B.ByteString -> IO ()
  216   -- | Upload data to dynamic vertex buffer.
  217   contextUploadVertexBuffer :: c -> VertexBufferId d -> B.ByteString -> IO ()
  218   -- | Draw (instanced).
  219   contextDraw :: c
  220     -> Int -- ^ Instances count (1 for non-instanced).
  221     -> Int -- ^ Indices count.
  222     -> IO ()
  223   -- | Replay deferred context on immediate context.
  224   contextPlay :: Context dc d => c -> dc -> IO ()
  225   contextPlay _ _ = throwIO $ DescribeFirstException "playing deferred context is not supported"
  226   -- | Perform rendering. Initial state is context's default state.
  227   contextRender :: c -> IO a -> IO a
  228   ------- Setup commands.
  229   -- | Set framebuffer.
  230   contextSetFrameBuffer :: c -> FrameBufferId d -> IO a -> IO a
  231   -- | Set viewport (left, top, right, bottom).
  232   contextSetViewport :: c -> Int4 -> IO a -> IO a
  233   -- | Get current viewport.
  234   contextGetViewport :: c -> IO Int4
  235   -- | Set scissor (left, top, right, bottom).
  236   contextSetScissor :: c -> Maybe Int4 -> IO a -> IO a
  237   -- | Get current scissor.
  238   contextGetScissor :: c -> IO (Maybe Int4)
  239   -- | Set vertex buffer.
  240   contextSetVertexBuffer :: c -> Int -> VertexBufferId d -> IO a -> IO a
  241   -- | Set index buffer.
  242   contextSetIndexBuffer :: c -> IndexBufferId d -> IO a -> IO a
  243   -- | Set uniform buffer.
  244   contextSetUniformBuffer :: c -> Int -> UniformBufferId d -> IO a -> IO a
  245   -- | Set sampler.
  246   contextSetSampler :: c -> Int -> TextureId d -> SamplerStateId d -> IO a -> IO a
  247   -- | Set blend state.
  248   contextSetBlendState :: c -> BlendStateId d -> IO a -> IO a
  249   -- | Set depth-test function.
  250   contextSetDepthTestFunc :: c -> DepthTestFunc -> IO a -> IO a
  251   -- | Set depth write flag.
  252   contextSetDepthWrite :: c -> Bool -> IO a -> IO a
  253   -- | Set program.
  254   contextSetProgram :: c -> ProgramId d -> IO a -> IO a
  255 
  256 -- | Presenter class.
  257 class (System s, Context c d) => Presenter p s c d | p -> s c d where
  258   setPresenterMode :: p -> Maybe (DisplayModeId s) -> IO ()
  259   -- | Perform rendering on presenter's surface.
  260   -- Presenter's framebuffer, viewport, etc will be automatically set
  261   -- as an initial state.
  262   presenterRender :: p -> c -> IO a -> IO a
  263 
  264 -- | Device information structure.
  265 data DeviceInfo device = DeviceInfo
  266   { deviceName :: !T.Text
  267   , deviceDisplays :: [(DisplayId device, DisplayInfo device)]
  268   }
  269 
  270 -- | Display information structure.
  271 data DisplayInfo device = DisplayInfo
  272   { displayName :: !T.Text
  273   , displayModes :: [(DisplayModeId device, DisplayModeInfo)]
  274   }
  275 
  276 -- | Display mode information structure.
  277 data DisplayModeInfo = DisplayModeInfo
  278   { displayModeName :: !T.Text
  279   , displayModeWidth :: !Int
  280   , displayModeHeight :: !Int
  281   , displayModeRefreshRate :: !Rational
  282   } deriving Show
  283 
  284 -- | Index topology.
  285 data IndexTopology
  286   = IndexTopologyPoints
  287   | IndexTopologyLines
  288   | IndexTopologyLineStrip
  289   | IndexTopologyTriangles
  290   | IndexTopologyTriangleStrip
  291   | IndexTopologyPatches {-# UNPACK #-} !Int
  292   deriving (Eq, Generic)
  293 instance S.Serialize IndexTopology
  294 
  295 -- | Index stride.
  296 data IndexStride
  297   = IndexStride32Bit
  298   | IndexStride16Bit
  299   deriving (Eq, Generic)
  300 instance S.Serialize IndexStride
  301 
  302 -- | Depth test function.
  303 data DepthTestFunc
  304   = DepthTestFuncNever
  305   | DepthTestFuncLess
  306   | DepthTestFuncLessOrEqual
  307   | DepthTestFuncEqual
  308   | DepthTestFuncNonEqual
  309   | DepthTestFuncGreaterOrEqual
  310   | DepthTestFuncGreater
  311   | DepthTestFuncAlways
  312   deriving Eq
  313 
  314 -- | Rendering monad.
  315 type Render c = StackT (ReaderT c IO)
  316 
  317 renderSetup :: (forall a. c -> IO a -> IO a) -> Render c ()
  318 renderSetup setup = StackT $ \q -> do
  319   c <- ask
  320   mapReaderT (setup c) $ q ()
  321 
  322 renderAction :: (c -> IO a) -> Render c a
  323 renderAction action = StackT $ \q -> do
  324   c <- ask
  325   lift (action c) >>= q
  326 
  327 -- | Scope for rendering state.
  328 -- Context state will be restored after the scope.
  329 renderScope :: Render c a -> Render c a
  330 renderScope = scope
  331 
  332 -- | Set current framebuffer.
  333 renderFrameBuffer :: Context c d => FrameBufferId d -> Render c ()
  334 renderFrameBuffer fb = renderSetup $ \c q -> contextSetFrameBuffer c fb q
  335 
  336 -- | Set current viewport (vector with left, top, right, bottom).
  337 renderViewport :: Context c d => Int4 -> Render c ()
  338 renderViewport viewport = renderSetup $ \c q -> contextSetViewport c viewport q
  339 
  340 -- | Get current viewport.
  341 renderGetViewport :: Context c d => Render c Int4
  342 renderGetViewport = renderAction contextGetViewport
  343 
  344 -- | Set current scissor (vector with left, top, right, bottom).
  345 renderScissor :: Context c d => Maybe Int4 -> Render c ()
  346 renderScissor scissor = renderSetup $ \c q -> contextSetScissor c scissor q
  347 
  348 -- | Get current scissor.
  349 renderGetScissor :: Context c d => Render c (Maybe Int4)
  350 renderGetScissor = renderAction contextGetScissor
  351 
  352 -- | Set intersection between specified and current scissor as scissor.
  353 renderIntersectScissor :: Context c d => Int4 -> Render c ()
  354 renderIntersectScissor scissor@(Vec4 left top right bottom) = do
  355   currentScissor <- renderGetScissor
  356   renderScissor $ Just $ case currentScissor of
  357     Just (Vec4 currentLeft currentTop currentRight currentBottom) ->
  358       Vec4 (max left currentLeft) (max top currentTop) (min right currentRight) (min bottom currentBottom)
  359     Nothing -> scissor
  360 
  361 -- | Set vertex buffer.
  362 renderVertexBuffer :: Context c d => Int -> VertexBufferId d -> Render c ()
  363 renderVertexBuffer i vb = renderSetup $ \c q -> contextSetVertexBuffer c i vb q
  364 
  365 -- | Set current index buffer.
  366 renderIndexBuffer :: Context c d => IndexBufferId d -> Render c ()
  367 renderIndexBuffer ib = renderSetup $ \c q -> contextSetIndexBuffer c ib q
  368 
  369 -- | Set uniform buffer.
  370 renderUniformBuffer :: Context c d => Int -> UniformBufferId d -> Render c ()
  371 renderUniformBuffer i ub = renderSetup $ \c q -> contextSetUniformBuffer c i ub q
  372 
  373 -- | Set sampler.
  374 renderSampler :: Context c d => Int -> TextureId d -> SamplerStateId d -> Render c ()
  375 renderSampler i t s = renderSetup $ \c q -> contextSetSampler c i t s q
  376 
  377 -- | Set blend state.
  378 renderBlendState :: Context c d => BlendStateId d -> Render c ()
  379 renderBlendState b = renderSetup $ \c q -> contextSetBlendState c b q
  380 
  381 -- | Set depth test function.
  382 renderDepthTestFunc :: Context c d => DepthTestFunc -> Render c ()
  383 renderDepthTestFunc f = renderSetup $ \c q -> contextSetDepthTestFunc c f q
  384 
  385 -- | Set depth write flag.
  386 renderDepthWrite :: Context c d => Bool -> Render c ()
  387 renderDepthWrite f = renderSetup $ \c q -> contextSetDepthWrite c f q
  388 
  389 -- | Set current program.
  390 renderProgram :: Context c d => ProgramId d -> Render c ()
  391 renderProgram p = renderSetup $ \c q -> contextSetProgram c p q
  392 
  393 -- | Clear render target.
  394 renderClearColor :: Context c d => Int -> Float4 -> Render c ()
  395 renderClearColor i color = renderAction $ \c -> contextClearColor c i color
  396 
  397 -- | Clear depth.
  398 renderClearDepth :: Context c d => Float -> Render c ()
  399 renderClearDepth depth = renderAction $ \c -> contextClearDepth c depth
  400 
  401 -- | Clear stencil.
  402 renderClearStencil :: Context c d => Int -> Render c ()
  403 renderClearStencil stencil = renderAction $ \c -> contextClearStencil c stencil
  404 
  405 -- | Clear depth and stencil.
  406 renderClearDepthStencil :: Context c d => Float -> Int -> Render c ()
  407 renderClearDepthStencil depth stencil = renderAction $ \c -> contextClearDepthStencil c depth stencil
  408 
  409 -- | Upload data to uniform buffer.
  410 renderUploadUniformBuffer :: Context c d => UniformBufferId d -> B.ByteString -> Render c ()
  411 renderUploadUniformBuffer ub bytes = renderAction $ \c -> contextUploadUniformBuffer c ub bytes
  412 
  413 -- | Upload data to dynamic vertex buffer.
  414 renderUploadVertexBuffer :: Context c d => VertexBufferId d -> B.ByteString -> Render c ()
  415 renderUploadVertexBuffer vb bytes = renderAction $ \c -> contextUploadVertexBuffer c vb bytes
  416 
  417 -- | Draw.
  418 renderDraw :: Context c d
  419   => Int -- ^ Indices count.
  420   -> Render c ()
  421 renderDraw = renderDrawInstanced 1
  422 
  423 -- | Draw instanced.
  424 renderDrawInstanced :: Context c d
  425   => Int -- ^ Instances count.
  426   -> Int -- ^ Indices count.
  427   -> Render c ()
  428 renderDrawInstanced instancesCount indicesCount = renderAction $ \c -> contextDraw c instancesCount indicesCount
  429 
  430 -- | Play deferred context on immediate context.
  431 renderPlay :: (Context c d, Context dc d) => dc -> Render c ()
  432 renderPlay deferredContext = renderAction $ \c -> contextPlay c deferredContext
  433 
  434 -- | Perform offscreen rendering.
  435 render :: Context c d => c -> Render c a -> IO a
  436 render c f = contextRender c $ runReaderT (runStackT f) c
  437 
  438 -- | Perform rendering on presenter.
  439 present :: Presenter p s c d => p -> Render c a -> Render c a
  440 present p f = renderAction $ \c -> presenterRender p c $ runReaderT (runStackT f) c