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

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}

module Terminal.Game.Layer.Object.Test where

-- Test (pure) MonadGame* typeclass implementation for testing purposes.

import Terminal.Game.Layer.Object.Interface

import qualified Control.Monad.RWS as S


-----------
-- TYPES --
-----------

data Env = Env { Env -> Bool
eLogging :: Bool,
                 Env -> [Event]
eEvents  :: [Event] }

data TestEvent = TCleanUpError
               | TQuitGame
               | TSetupDisplay
               | TShutdownDisplay
               | TStartGame
               | TStartEvents
               | TStopEvents
        deriving (TestEvent -> TestEvent -> Bool
(TestEvent -> TestEvent -> Bool)
-> (TestEvent -> TestEvent -> Bool) -> Eq TestEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestEvent -> TestEvent -> Bool
$c/= :: TestEvent -> TestEvent -> Bool
== :: TestEvent -> TestEvent -> Bool
$c== :: TestEvent -> TestEvent -> Bool
Eq, Int -> TestEvent -> ShowS
[TestEvent] -> ShowS
TestEvent -> String
(Int -> TestEvent -> ShowS)
-> (TestEvent -> String)
-> ([TestEvent] -> ShowS)
-> Show TestEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestEvent] -> ShowS
$cshowList :: [TestEvent] -> ShowS
show :: TestEvent -> String
$cshow :: TestEvent -> String
showsPrec :: Int -> TestEvent -> ShowS
$cshowsPrec :: Int -> TestEvent -> ShowS
Show)

newtype Test a = Test (S.RWS Env [TestEvent] [Event] a)
               deriving (a -> Test b -> Test a
(a -> b) -> Test a -> Test b
(forall a b. (a -> b) -> Test a -> Test b)
-> (forall a b. a -> Test b -> Test a) -> Functor Test
forall a b. a -> Test b -> Test a
forall a b. (a -> b) -> Test a -> Test b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Test b -> Test a
$c<$ :: forall a b. a -> Test b -> Test a
fmap :: (a -> b) -> Test a -> Test b
$cfmap :: forall a b. (a -> b) -> Test a -> Test b
Functor, Functor Test
a -> Test a
Functor Test
-> (forall a. a -> Test a)
-> (forall a b. Test (a -> b) -> Test a -> Test b)
-> (forall a b c. (a -> b -> c) -> Test a -> Test b -> Test c)
-> (forall a b. Test a -> Test b -> Test b)
-> (forall a b. Test a -> Test b -> Test a)
-> Applicative Test
Test a -> Test b -> Test b
Test a -> Test b -> Test a
Test (a -> b) -> Test a -> Test b
(a -> b -> c) -> Test a -> Test b -> Test c
forall a. a -> Test a
forall a b. Test a -> Test b -> Test a
forall a b. Test a -> Test b -> Test b
forall a b. Test (a -> b) -> Test a -> Test b
forall a b c. (a -> b -> c) -> Test a -> Test b -> Test c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Test a -> Test b -> Test a
$c<* :: forall a b. Test a -> Test b -> Test a
*> :: Test a -> Test b -> Test b
$c*> :: forall a b. Test a -> Test b -> Test b
liftA2 :: (a -> b -> c) -> Test a -> Test b -> Test c
$cliftA2 :: forall a b c. (a -> b -> c) -> Test a -> Test b -> Test c
<*> :: Test (a -> b) -> Test a -> Test b
$c<*> :: forall a b. Test (a -> b) -> Test a -> Test b
pure :: a -> Test a
$cpure :: forall a. a -> Test a
$cp1Applicative :: Functor Test
Applicative, Applicative Test
a -> Test a
Applicative Test
-> (forall a b. Test a -> (a -> Test b) -> Test b)
-> (forall a b. Test a -> Test b -> Test b)
-> (forall a. a -> Test a)
-> Monad Test
Test a -> (a -> Test b) -> Test b
Test a -> Test b -> Test b
forall a. a -> Test a
forall a b. Test a -> Test b -> Test b
forall a b. Test a -> (a -> Test b) -> Test b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Test a
$creturn :: forall a. a -> Test a
>> :: Test a -> Test b -> Test b
$c>> :: forall a b. Test a -> Test b -> Test b
>>= :: Test a -> (a -> Test b) -> Test b
$c>>= :: forall a b. Test a -> (a -> Test b) -> Test b
$cp1Monad :: Applicative Test
Monad,
                         S.MonadWriter [TestEvent])

runTest :: Test a -> Env -> (a, [TestEvent])
runTest :: Test a -> Env -> (a, [TestEvent])
runTest (Test RWS Env [TestEvent] [Event] a
m) Env
e = RWS Env [TestEvent] [Event] a -> Env -> [Event] -> (a, [TestEvent])
forall r w s a. RWS r w s a -> r -> s -> (a, w)
S.evalRWS RWS Env [TestEvent] [Event] a
m Env
e (Env -> [Event]
eEvents Env
e)


-----------
-- CLASS --
-----------

tconst :: a -> Test a
tconst :: a -> Test a
tconst a
a = RWS Env [TestEvent] [Event] a -> Test a
forall a. RWS Env [TestEvent] [Event] a -> Test a
Test (RWS Env [TestEvent] [Event] a -> Test a)
-> RWS Env [TestEvent] [Event] a -> Test a
forall a b. (a -> b) -> a -> b
$ a -> RWS Env [TestEvent] [Event] a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

mockHandle :: InputHandle
mockHandle :: InputHandle
mockHandle = MVar [Event] -> [ThreadId] -> InputHandle
InputHandle (String -> MVar [Event]
forall a. HasCallStack => String -> a
error String
"mock handle keyMvar")
                         (String -> [ThreadId]
forall a. HasCallStack => String -> a
error String
"mock handle threads")

instance MonadInput Test where
    startEvents :: TPS -> Test InputHandle
startEvents TPS
_ = [TestEvent] -> Test ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
S.tell [TestEvent
TStartEvents] Test () -> Test InputHandle -> Test InputHandle
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                    InputHandle -> Test InputHandle
forall (m :: * -> *) a. Monad m => a -> m a
return InputHandle
mockHandle
    pollEvents :: MVar [Event] -> Test [Event]
pollEvents MVar [Event]
_ = RWS Env [TestEvent] [Event] [Event] -> Test [Event]
forall a. RWS Env [TestEvent] [Event] a -> Test a
Test (RWS Env [TestEvent] [Event] [Event] -> Test [Event])
-> RWS Env [TestEvent] [Event] [Event] -> Test [Event]
forall a b. (a -> b) -> a -> b
$ ([Event] -> ([Event], [Event]))
-> RWS Env [TestEvent] [Event] [Event]
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
S.state (\[Event]
s -> ([Event]
s, []))
    stopEvents :: [ThreadId] -> Test ()
stopEvents [ThreadId]
_ = [TestEvent] -> Test ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
S.tell [TestEvent
TStopEvents]

instance MonadTimer Test where
    getTime :: Test TPS
getTime = TPS -> Test TPS
forall (m :: * -> *) a. Monad m => a -> m a
return TPS
1
    sleepABit :: TPS -> Test ()
sleepABit TPS
_ = () -> Test ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance MonadException Test where
    cleanUpErr :: Test a -> Test b -> Test a
cleanUpErr Test a
a Test b
_ = [TestEvent] -> Test ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
S.tell [TestEvent
TCleanUpError] Test () -> Test a -> Test a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Test a
a
    throwExc :: ATGException -> Test a
throwExc ATGException
e = String -> Test a
forall a. HasCallStack => String -> a
error (String -> Test a)
-> (ATGException -> String) -> ATGException -> Test a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATGException -> String
forall a. Show a => a -> String
show (ATGException -> Test a) -> ATGException -> Test a
forall a b. (a -> b) -> a -> b
$ ATGException
e
            -- we shouldn’t need strict sequencing in testing
            -- xxx make it a list of TestEvent + the error
            -- (not Either Err a!)

instance MonadLogic Test where
    -- if eof, quit
    checkQuit :: (s -> Bool) -> s -> Test Bool
checkQuit s -> Bool
fs s
s = RWS Env [TestEvent] [Event] Bool -> Test Bool
forall a. RWS Env [TestEvent] [Event] a -> Test a
Test (RWS Env [TestEvent] [Event] Bool -> Test Bool)
-> RWS Env [TestEvent] [Event] Bool -> Test Bool
forall a b. (a -> b) -> a -> b
$ RWS Env [TestEvent] [Event] [Event]
forall s (m :: * -> *). MonadState s m => m s
S.get RWS Env [TestEvent] [Event] [Event]
-> ([Event] -> RWS Env [TestEvent] [Event] Bool)
-> RWS Env [TestEvent] [Event] Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                               [] -> Bool -> RWS Env [TestEvent] [Event] Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                               [Event]
_  -> Bool -> RWS Env [TestEvent] [Event] Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> Bool
fs s
s)
    -- xxx astrai anche per narrate

instance MonadDisplay Test where
    setupDisplay :: Test ()
setupDisplay = () () -> Test () -> Test ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [TestEvent] -> Test ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
S.tell [TestEvent
TSetupDisplay]
    clearDisplay :: Test ()
clearDisplay = () -> Test ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    displaySize :: Test (Maybe Dimensions)
displaySize = Maybe Dimensions -> Test (Maybe Dimensions)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Dimensions -> Test (Maybe Dimensions))
-> Maybe Dimensions -> Test (Maybe Dimensions)
forall a b. (a -> b) -> a -> b
$ Dimensions -> Maybe Dimensions
forall a. a -> Maybe a
Just (Int
8000, Int
2400)
        -- xxx no display size but check display size
    blitPlane :: Maybe Plane -> Plane -> Test ()
blitPlane Maybe Plane
_ Plane
_ = () -> Test ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    shutdownDisplay :: Test ()
shutdownDisplay = () () -> Test () -> Test ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [TestEvent] -> Test ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
S.tell [TestEvent
TShutdownDisplay]