I need to create more contexts to be threadsafe.

src/Init.hs

@@ -59,6 +59,8 @@ init = do
     , uuid            = []
     , worldState      = ws
     , stateData       = None
+    , threadContext   = Nothing
+    , mainContext     = Nothing
     }
 
 loadPlayerSprite

src/Load.hs

@@ -2,6 +2,8 @@ module Load where
 
 import Affection as A
 
+import qualified SDL
+
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar
 import Control.Monad (when)
@@ -25,24 +27,38 @@ loadLoad = do
   ud <- getAffection
   progress <- liftIO $ newMVar 0
   future <- liftIO $ newEmptyMVar
-  _ <- liftIO $ loadFork (worldState ud) (nano ud) future progress
+  _ <- liftIO $ createFont (nano ud) "bedstead"
+    (FileName "assets/font/Bedstead-Semicondensed.ttf")
+  _ <- liftIO $ forkIO $
+    loadFork
+      (worldState ud)
+      (window ud)
+      (threadContext ud)
+      (nano ud)
+      future
+      progress
+  SDL.glMakeCurrent (fromJust $ window ud) (fromJust $ mainContext ud)
   putAffection ud
     { stateMVar = future
     , stateProgress = progress
     , state = Load
+    , assetFonts  = M.fromList
+      [ (FontBedstead, "bedstead")
+      ]
     }
 
 loadFork
   :: (SystemState Entity IO)
+  -> Maybe SDL.Window
+  -> Maybe SDL.GLContext
   -> Context
   -> MVar (SystemState Entity IO, StateData)
   -> MVar Float
   -> IO ()
-loadFork ws nvg future progress = do
+loadFork ws (Just win) (Just glc) nvg future progress = do
   let stateSteps = 20
       increment = 1 / stateSteps
-  _ <- createFont nvg "bedstead"
+  SDL.glMakeCurrent win glc
-    (FileName "assets/font/Bedstead-Semicondensed.ttf")
   modifyMVar_ progress (return . (+ increment))
   mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
   modifyMVar_ progress (return . (+ increment))
@@ -111,9 +127,6 @@ loadFork ws nvg future progress = do
       { loadAssetImages = M.fromList imgs
       , loadAssetAnims  = M.fromList
         (playerStanding ++ playerWalking)
-      , loadAssetFonts  = M.fromList
-        [ (FontBedstead, "bedstead")
-        ]
       }
     )
 
@@ -122,7 +135,9 @@ drawLoad = do
   ud <- getAffection
   let ctx = nano ud
   progress <- liftIO $ readMVar (stateProgress ud)
-  liftIO $ drawLoadScreen ud progress
+  liftIO $ do
+    logIO A.Verbose ("LoadProgress: " ++ show progress)
+    drawLoadScreen ud progress
 
 updateLoad :: Double -> Affection UserData ()
 updateLoad _ = do
@@ -134,7 +149,6 @@ updateLoad _ = do
       putAffection ud
         { assetImages     = loadAssetImages ld
         , assetAnimations = loadAssetAnims ld
-        , assetFonts      = loadAssetFonts ld
         , state           = Menu
         , stateData       = None
         }

src/Main.hs

@@ -1,19 +1,27 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
 module Main where
 
 import Affection as A
 
 import qualified SDL
+import qualified SDL.Raw.Video as SDL (glSetAttribute)
+import qualified SDL.Raw.Enum as SDL
 
 import NanoVG hiding (V2(..), V3(..))
 
 import Linear
 
+import Foreign.C.Types (CInt(..))
+
 -- internal imports
 
 import Types
 import StateMachine ()
 import Init
 
+foreign import ccall unsafe "glewInit"
+  glewInit :: IO CInt
+
 main :: IO ()
 main = do
   let config = AffectionConfig
@@ -39,10 +47,19 @@ main = do
 
 pre :: Affection UserData ()
 pre = do
+  ad <- A.get
+  ud <- getAffection
+  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
+  threadContext <- SDL.glCreateContext (drawWindow ad)
+  SDL.glMakeCurrent (drawWindow ad) (glContext ad)
   Subsystems w m <- subsystems <$> getAffection
   _ <- partSubscribe w (fitViewport (1280/720))
   _ <- partSubscribe w exitOnWindowClose
-  return ()
+  putAffection ud
+    { threadContext = Just threadContext
+    , mainContext = Just (glContext ad)
+    , window = Just (drawWindow ad)
+    }
 
 update :: Double -> Affection UserData ()
 update dt = do

src/Types/StateData.hs

@@ -17,7 +17,6 @@ data StateData
   | LoadData
     { loadAssetImages :: Map ImgId Image
     , loadAssetAnims  :: Map AnimId Animation
-    , loadAssetFonts  :: Map FontId Text
     }
   | MenuData                                                                       
     { mapMat      :: Matrix TileState                                              

src/Types/UserData.hs

@@ -7,6 +7,8 @@ import Affection
 
 import Control.Concurrent.STM
 
+import qualified SDL
+
 import NanoVG hiding (V2(..), V3(..))
 
 import qualified Data.Map.Strict as M
@@ -35,6 +37,9 @@ data UserData = UserData
   , stateData       :: StateData
   , stateMVar       :: MVar (SystemState Entity IO, StateData)
   , stateProgress   :: MVar Float
+  , threadContext   :: Maybe SDL.GLContext
+  , mainContext     :: Maybe SDL.GLContext
+  , window          :: Maybe SDL.Window
   }
 
 data State

src/Util.hs

@@ -176,14 +176,18 @@ naviGraph imgmat (V2 r c) =
 drawLoadScreen :: UserData -> Float -> IO ()
 drawLoadScreen ud progress = do
   let ctx = nano ud
+  save ctx
   fillColor ctx (rgb 255 128 0)
   fontSize ctx 100
   fontFace ctx (assetFonts ud Map.! FontBedstead)
   textAlign ctx (S.fromList [AlignCenter, AlignTop])
   textBox ctx 0 300 1280 "Loading"
+  beginPath ctx
   rect ctx
     (640 - 640 * realToFrac progress) 450 (1280 * realToFrac progress) 20
+  closePath ctx
   fill ctx
+  restore ctx
 
 loadAnimationSprites
   :: FilePath   -- Path to Sprite map