Test.hs

-------------------------------------------------------------------------------
-- 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 { eLogging :: Bool,
                 eEvents  :: [Event] }

data TestEvent = TCleanUpError
               | TQuitGame
               | TSetupDisplay
               | TShutdownDisplay
               | TStartGame
               | TStartEvents
               | TStopEvents
        deriving (Eq, Show)

newtype Test a = Test (S.RWS Env [TestEvent] [Event] a)
               deriving (Functor, Applicative, Monad,
                         S.MonadWriter [TestEvent])

runTest :: Test a -> Env -> (a, [TestEvent])
runTest (Test m) e = S.evalRWS m e (eEvents e)


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

tconst :: a -> Test a
tconst a = Test $ return a

mockHandle :: InputHandle
mockHandle = InputHandle (error "mock handle keyMvar")
                         (error "mock handle threads")

instance MonadInput Test where
    startEvents _ = S.tell [TStartEvents] >>
                    return mockHandle
    pollEvents _ = Test $ S.state (\s -> (s, []))
    stopEvents _ = S.tell [TStopEvents]

instance MonadTimer Test where
    getTime = return 1
    sleepABit _ = return ()

instance MonadException Test where
    cleanUpErr a _ = S.tell [TCleanUpError] >> a
    throwExc e = error . show $ 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 fs s = Test $ S.get >>= \case
                               [] -> return True
                               _  -> return (fs s)
    -- xxx astrai anche per narrate

instance MonadDisplay Test where
    setupDisplay = () <$ S.tell [TSetupDisplay]
    clearDisplay = return ()
    displaySize = return $ Just (8000, 2400)
        -- xxx no display size but check display size
    blitPlane _ _ _ _ = return ()
    shutdownDisplay = () <$ S.tell [TShutdownDisplay]