Implement renderer message queue and unique IDs

This patch first adds a new module `Polar.Unique` that can generate
unique IDs for any type with an instance of `Enum`. This is based around
engine storage and the initial ID is set as `toEnum 0` of the type in
question. `succ` is used to increment the ID.

Additionally, this patch implements a basic message queue for the
renderer, built on top of engine storage with a `TChan` channel as the
actual queue.

This issue partially addresses #13.

examples/basic/Main.hs

@@ -1,13 +1,19 @@
 module Main where
 
+import Control.Monad.RWS (void, tell)
 import Polar
+import Polar.System.Renderer
 import Polar.System.Renderer.OpenGL_3_2
 
 hello :: System
 hello = defaultSystem "Hello"
     & startup  .~ logWrite NOTICE "Hello!"
     & shutdown .~ logWrite NOTICE "Goodbye... :("
 
+prim :: System
+prim = defaultSystem "Primitive Submitter"
+    & startup .~ tell [SysCoreAction (void $ submitPrimitive ())]
+
 main :: IO ()
 main = run $ defaultEngine
-    & systems .~ [hello, renderer]
+    & systems .~ [hello, prim, renderer]

polar-engine.cabal

@@ -21,11 +21,13 @@ library
                        Polar.Log,
                        Polar.Exit,
                        Polar.Storage,
+                       Polar.Unique,
                        Polar.Core.Config,
                        Polar.Core.File,
                        Polar.Core.Run,
                        Polar.Sys.Run,
                        Polar.Logic.Run,
+                       Polar.System.Renderer,
                        Polar.System.Renderer.OpenGL_3_2,
                        Polar.Shader.Compiler.GLSL150,
                        Polar.Types,
@@ -49,7 +51,7 @@ library
 test-suite example-basic
   type:                exitcode-stdio-1.0
   main-is:             Main.hs
-  build-depends:       base >=4.8 && <5.0, polar-engine
+  build-depends:       base >=4.8 && <5.0, mtl >=2.2, polar-engine
   default-language:    Haskell2010
   hs-source-dirs:      examples/basic
   ghc-options:         -W

src/Polar/System/Renderer.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+{-|
+  Module      : Polar.System.Renderer
+  Copyright   : (c) 2016 David Farrell
+  License     : Apache-2.0
+  Stability   : unstable
+  Portability : non-portable (GHC extensions)
+
+  Generic renderer utility functions.
+-}
+
+module Polar.System.Renderer
+( submitPrimitive, readRendererMsg
+) where
+
+import Data.Hashable
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TChan
+import GHC.Generics
+import Polar.Storage
+import Polar.Unique
+
+data RendererKey = RendererKey deriving Generic
+instance Hashable RendererKey
+
+submitPrimitive :: (MonadIO m, StorePolar m) => () -> m Integer
+submitPrimitive x = do
+    uid <- unique
+    chan <- mRetrieveKeyed RendererKey >>= \case
+        Nothing -> do
+            c <- liftIO (atomically newTChan)
+            storeKeyed RendererKey c
+            pure c
+        Just c  -> pure c
+    liftIO $ atomically (writeTChan chan (uid, x))
+    pure uid
+
+readRendererMsg :: (MonadIO m, StorePolar m) => m (Maybe (Integer, ()))
+readRendererMsg = do
+    mRetrieveKeyed RendererKey >>= \case
+        Nothing   -> pure Nothing
+        Just chan -> liftIO $ atomically (tryReadTChan chan)

src/Polar/System/Renderer/OpenGL_3_2.hs

@@ -29,6 +29,7 @@ import Polar.Types
 import Polar.Log
 import Polar.Exit
 import Polar.Storage
+import Polar.System.Renderer
 import Polar.Shader (compile)
 import Polar.Shader.Types
 import Polar.Shader.Compiler.GLSL150 (GLSL150(..))
@@ -77,6 +78,9 @@ tickF = do
 render :: GLFW.Window -> Core ()
 render win = do
     gl (GL.clear [GL.ColorBuffer, GL.DepthBuffer])
+    readRendererMsg >>= \case
+        Nothing -> pure ()
+        Just m  -> logWrite TRACE ("Received renderer message: " ++ show m)
     traverse_ renderOne =<< retrieveAll
     liftIO (GLFW.swapBuffers win)
     liftIO GLFW.pollEvents

src/Polar/Unique.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+{-|
+  Module      : Polar.Unique
+  Copyright   : (c) 2016 David Farrell
+  License     : Apache-2.0
+  Stability   : unstable
+  Portability : non-portable (GHC extensions)
+
+  Functions for generating unique values.
+-}
+
+module Polar.Unique (unique) where
+
+import Data.Typeable
+import Data.Hashable
+import GHC.Generics
+import Polar.Storage
+
+data UniqueKey = UniqueKey deriving Generic
+instance Hashable UniqueKey
+
+unique :: (StorePolar m, Enum a, Typeable a) => m a
+unique = do
+    x <- maybe (toEnum 0) succ <$> mRetrieveKeyed UniqueKey
+    storeKeyed UniqueKey x
+    pure x