tracer/src/Main.hs

{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Affection as A

import qualified 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
        { initComponents = All
        , windowTitle    = "Tracer"
        , windowConfig   = SDL.defaultWindow
          { SDL.windowInitialSize = V2 1280 720
          , SDL.windowResizable   = True
          , SDL.windowOpenGL      = Just SDL.defaultOpenGL
            { SDL.glProfile = SDL.Core SDL.Normal 3 3
            }
          }
        , canvasSize     = Nothing
        , preLoop        = pre >> smLoad Load
        , eventLoop      = handle
        , updateLoop     = update
        , drawLoop       = draw
        , loadState      = Init.init
        , cleanUp        = const (return ())
        , initScreenMode = SDL.Windowed
        }
  withAffection config

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
  putAffection ud
    { threadContext = Just threadContext
    , mainContext = Just (glContext ad)
    , window = Just (drawWindow ad)
    }

update :: Double -> Affection UserData ()
update dt = do
  ud <- getAffection
  smUpdate (state ud) dt

draw :: Affection UserData ()
draw = do
  ud <- getAffection
  liftIO $ beginFrame (nano ud) 1280 720 1
  smDraw (state ud)
  liftIO $ endFrame (nano ud)

handle :: [SDL.EventPayload] -> Affection UserData ()
handle evs = do
  s <- state <$> getAffection
  smEvent s evs

exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose (MsgWindowClose _ _) = do
  liftIO $ logIO A.Debug "Window Closed"
  quit
exitOnWindowClose _ = return ()