Interface.hs

-------------------------------------------------------------------------------
-- Layer 2 (mockable IO), as per
-- https://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html
-- 2019 Francesco Ariis GPLv3
-------------------------------------------------------------------------------

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}

module Terminal.Game.Layer.Object.Interface where

import Terminal.Game.Plane

import qualified Control.Concurrent as CC
import qualified Control.Monad.Catch as MC
import qualified Data.Serialize     as S
import qualified GHC.Generics       as G
import qualified Test.QuickCheck    as Q


-- mtl inferface for game

type MonadGameIO m = (MonadInput m, MonadTimer m,
                      MonadException m, MonadLogic m,
                      MonadDisplay m)


----------------
-- Game input --
----------------

-- | Frames per second.
type FPS = Integer

-- | An @Event@ is a 'Tick' (time passes) or a 'KeyPress'.
data Event = Tick
           | KeyPress Char
           deriving (Show, Eq, G.Generic)

instance S.Serialize Event where

instance Q.Arbitrary Event where
  arbitrary = Q.oneof [ pure Tick,
                        KeyPress <$> Q.arbitrary ]

data InputHandle = InputHandle
            { ihKeyMVar    :: CC.MVar [Event],
              ihOpenThreds :: [CC.ThreadId] }

class Monad m => MonadInput m where
    startEvents :: FPS -> m InputHandle
    pollEvents  :: CC.MVar [Event] -> m [Event]
    stopEvents :: [CC.ThreadId] -> m ()

-----------------
-- Game timing --
-----------------

class Monad m => MonadTimer m where
    getTime :: m Integer     -- to nanoseconds
    sleepABit :: FPS -> m () -- useful not to hammer cpu while polling

--------------------
-- Error handling --
--------------------

-- if a fails, do b (useful for cleaning up)
class Monad m => MonadException m where
    cleanUpErr :: m a -> m b -> m a
    throwExc :: ATGException -> m a

-- | @ATGException@s are thrown synchronously for easier catching.
data ATGException =
      CannotGetDisplaySize
    | DisplayTooSmall Coords Coords -- ^ Required size and actual size.

instance Show ATGException where
    show CannotGetDisplaySize = "Cannot get display size!"
    show (DisplayTooSmall (gw, gh) (sw, sh)) =
            "This games requires a screen of " ++ show gw ++
            " columns and " ++ show gh ++ " rows.\n" ++
            "Yours only has " ++ show sw ++ " columns and " ++
            show sh ++ " rows!\n\n" ++
            "Please resize your terminal and relaunch " ++
            "the game!\n"

instance MC.Exception ATGException


-----------
-- Logic --
-----------

-- if a fails, do b (useful for cleaning up)
class Monad m => MonadLogic m where
    -- decide whether it's time to quit
    checkQuit :: (s -> Bool) -> s -> m Bool

-------------
-- Display --
-------------

class Monad m => MonadDisplay m where
    setupDisplay :: m ()
    clearDisplay :: m ()
    displaySize :: m (Maybe (Width, Height))
    blitPlane :: Width -> Height -> Maybe Plane -> Plane -> m ()
    shutdownDisplay :: m ()

-----------
-- Utils --
-----------

displaySizeErr :: (MonadDisplay m, MonadException m) => m (Width, Height)
displaySizeErr = displaySize >>= \case
                   Nothing -> throwExc CannotGetDisplaySize
                   Just d -> return d