From a8a78eb2cdd036f814025a401849e41278910626 Mon Sep 17 00:00:00 2001
From: Shockk <shokku.ra@gmail.com>
Date: Sun, 21 Aug 2016 13:47:03 +0100
Subject: [PATCH] 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                  |  8 ++++-
 polar-engine.cabal                      |  4 ++-
 src/Polar/System/Renderer.hs            | 46 +++++++++++++++++++++++++
 src/Polar/System/Renderer/OpenGL_3_2.hs |  4 +++
 src/Polar/Unique.hs                     | 28 +++++++++++++++
 5 files changed, 88 insertions(+), 2 deletions(-)
 create mode 100644 src/Polar/System/Renderer.hs
 create mode 100644 src/Polar/Unique.hs

diff --git a/examples/basic/Main.hs b/examples/basic/Main.hs
index c6a2bf4..0302e05 100644
--- a/examples/basic/Main.hs
+++ b/examples/basic/Main.hs
@@ -1,6 +1,8 @@
 module Main where
 
+import Control.Monad.RWS (void, tell)
 import Polar
+import Polar.System.Renderer
 import Polar.System.Renderer.OpenGL_3_2
 
 hello :: System
@@ -8,6 +10,10 @@ 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]
diff --git a/polar-engine.cabal b/polar-engine.cabal
index 17c69ba..68ef2ec 100644
--- a/polar-engine.cabal
+++ b/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
diff --git a/src/Polar/System/Renderer.hs b/src/Polar/System/Renderer.hs
new file mode 100644
index 0000000..8f9281d
--- /dev/null
+++ b/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)
diff --git a/src/Polar/System/Renderer/OpenGL_3_2.hs b/src/Polar/System/Renderer/OpenGL_3_2.hs
index 3f9cd52..385618c 100644
--- a/src/Polar/System/Renderer/OpenGL_3_2.hs
+++ b/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
diff --git a/src/Polar/Unique.hs b/src/Polar/Unique.hs
new file mode 100644
index 0000000..f5681b5
--- /dev/null
+++ b/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