-------------------------------------------------------------------------------
-- 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 --
----------------

-- | The number of 'Tick's fed each second to the logic function;
-- constant on every machine. /Frames/ per second might be lower
-- (depending on drawing function onerousness, terminal refresh rate,
-- etc.).
type TPS = Integer

-- | An @Event@ is a 'Tick' (time passes) or a 'KeyPress'.
data Event = Tick
           | KeyPress Char
           deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show, Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, (forall x. Event -> Rep Event x)
-> (forall x. Rep Event x -> Event) -> Generic Event
forall x. Rep Event x -> Event
forall x. Event -> Rep Event x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Event x -> Event
$cfrom :: forall x. Event -> Rep Event x
G.Generic)

instance S.Serialize Event where

instance Q.Arbitrary Event where
  arbitrary :: Gen Event
arbitrary = [Gen Event] -> Gen Event
forall a. [Gen a] -> Gen a
Q.oneof [ Event -> Gen Event
forall (f :: * -> *) a. Applicative f => a -> f a
pure Event
Tick,
                        Char -> Event
KeyPress (Char -> Event) -> Gen Char -> Gen Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Char
forall a. Arbitrary a => Gen a
Q.arbitrary ]

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

class Monad m => MonadInput m where
    startEvents :: TPS -> 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 :: TPS -> m () -- Given TPS, sleep a fracion of a single
                             -- Tick.

--------------------
-- 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

instance Show ATGException where
    show :: ATGException -> String
show ATGException
CannotGetDisplaySize = String
"Cannot get display size!"

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 Dimensions)
    blitPlane :: Maybe Plane -> Plane -> m ()
    shutdownDisplay :: m ()

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

displaySizeErr :: (MonadDisplay m, MonadException m) => m Dimensions
displaySizeErr :: m Dimensions
displaySizeErr = m (Maybe Dimensions)
forall (m :: * -> *). MonadDisplay m => m (Maybe Dimensions)
displaySize m (Maybe Dimensions)
-> (Maybe Dimensions -> m Dimensions) -> m Dimensions
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Maybe Dimensions
Nothing -> ATGException -> m Dimensions
forall (m :: * -> *) a. MonadException m => ATGException -> m a
throwExc ATGException
CannotGetDisplaySize
                   Just Dimensions
d -> Dimensions -> m Dimensions
forall (m :: * -> *) a. Monad m => a -> m a
return Dimensions
d