LambdaHack-0.11.0.1: test/UnitTestHelpers.hs

{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
-- | Monadic test harness and other stubs for unit tests.
module UnitTestHelpers
  ( CliState(..)
  , emptyCliState
  , executorCli
  , reportToTexts
  , stubLevel
  , stubState
  , stubCliState
  , stubItem
  , testActor
  , testActorId
  , testActorWithItem
  , testCliStateWithItem
  , testFactionId
  , testItemId
  , testLevel
  , testLevelId
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , fchanFrontendStub
  , CliMock(..)
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Control.Monad.IO.Class as IO
import           Control.Monad.Trans.State.Strict
  (StateT (StateT, runStateT), gets, state)
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as Text

import           Game.LambdaHack.Atomic (MonadStateWrite (..))
import           Game.LambdaHack.Client
import qualified Game.LambdaHack.Client.BfsM as BfsM
import           Game.LambdaHack.Client.HandleResponseM
import           Game.LambdaHack.Client.MonadClient
import           Game.LambdaHack.Client.State
  (StateClient (..), TGoal (..), Target (..), emptyStateClient, updateLeader)
import           Game.LambdaHack.Client.UI
  (MonadClientUI (..), SessionUI (..), emptySessionUI)
import           Game.LambdaHack.Client.UI.ActorUI (ActorUI (..))
import           Game.LambdaHack.Client.UI.Content.Screen
  (emptyScreenContent, rheight, rwidth)
import           Game.LambdaHack.Client.UI.ContentClientUI (coscreen, emptyCCUI)
import           Game.LambdaHack.Client.UI.Frontend
  (ChanFrontend (..), FrontReq (..))
import           Game.LambdaHack.Client.UI.Key (KMP (..))
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.Msg
import           Game.LambdaHack.Client.UI.Overlay
import           Game.LambdaHack.Client.UI.PointUI (PointUI (..))
import           Game.LambdaHack.Client.UI.UIOptions (UIOptions (..))
import           Game.LambdaHack.Common.Actor
  (Actor (..), ResDelta (..), Watchfulness (..))
import           Game.LambdaHack.Common.Area (Area, toArea, trivialArea)
import           Game.LambdaHack.Common.ClientOptions
  (ClientOptions (..), FullscreenMode (..), defClientOptions)
import           Game.LambdaHack.Common.Faction (Faction (..))
import           Game.LambdaHack.Common.Item
import           Game.LambdaHack.Common.Kind (COps (..), emptyUIFaction)
import           Game.LambdaHack.Common.Level (Level (..))
import           Game.LambdaHack.Common.Misc (FontSet (..))
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.Perception (emptyPer)
import           Game.LambdaHack.Common.Point (Point (..))
import           Game.LambdaHack.Common.State
  ( State
  , emptyState
  , unknownTileMap
  , updateActorD
  , updateActorMaxSkills
  , updateCOpsAndCachedData
  , updateDungeon
  , updateFactionD
  )
import           Game.LambdaHack.Common.Time (timeZero)
import           Game.LambdaHack.Common.Types
  (ActorId, FactionId, ItemId, LevelId)
import           Game.LambdaHack.Content.RuleKind (RuleContent (..))
import           Game.LambdaHack.Content.TileKind (unknownId)
import qualified Game.LambdaHack.Core.Dice as Dice
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Color (Color (..))
import           Game.LambdaHack.Definition.DefsInternal (toContentId)
import           Game.LambdaHack.Definition.Flavour

-- * UI frontend stub

-- Read UI requests from the client and send them to the frontend,
fchanFrontendStub :: ChanFrontend
fchanFrontendStub =
  ChanFrontend $ \case
    FrontFrame _ -> putStr "FrontFrame"
    FrontDelay _ -> putStr "FrontDelay"
    FrontKey _ _ -> return KMP {kmpKeyMod = K.escKM, kmpPointer = PointUI 0 0}
    FrontPressed -> return False
    FrontDiscardKey -> putStr "FrontDiscardKey"
    FrontResetKeys -> putStr "FrontResetKeys"
    FrontShutdown -> putStr "FrontShutdown"
    FrontPrintScreen -> putStr "FrontPrintScreen"

-- * Mock client state implementation

data CliState = CliState
  { cliState   :: State            -- ^ current global state
  , cliClient  :: StateClient      -- ^ current client state
  , cliSession :: Maybe SessionUI  -- ^ UI state, empty for AI clients

  -- Not needed for the mock monad (and blank line needed to avoid making this
  -- comment a haddock for @cliSession@ field):
  -- , cliDict    :: ChanServer
  -- , cliToSave  :: Save.ChanSave (StateClient, Maybe SessionUI)
  }

-- * Option stubs

stubUIOptions :: UIOptions
stubUIOptions = UIOptions
  { uCommands = []
  , uHeroNames = []
  , uVi = False
  , uLeftHand = False
  , uChosenFontset = ""
  , uAllFontsScale = 0.0
  , uFullscreenMode = NotFullscreen
  , uhpWarningPercent = 0
  , uMsgWrapColumn = 0
  , uHistoryMax = 0
  , uMaxFps = 0.0
  , uNoAnim = False
  , uOverrideCmdline = []
  , uFonts = []
  , uFontsets = []
  , uMessageColors = []
  }

stubClientOptions :: ClientOptions
stubClientOptions = defClientOptions
  { schosenFontset = Just "snoopy"
  , sfontsets =
      [("snoopy", FontSet { fontMapScalable = "scalable"
                          , fontMapBitmap = "bitmap"
                          , fontPropRegular = "propRegular"
                          , fontPropBold = "propBold"
                          , fontMono = "mono" })]
  }

stubItem :: Item
stubItem = Item { jkind = IdentityObvious (toContentId 0), jfid = Nothing, jflavour = dummyFlavour }

testLevel :: Level
testLevel = Level
  { lkind = toEnum 0
  , ldepth = Dice.AbsDepth 1
  , lfloor = EM.empty
  , lembed = EM.empty
  , lbig = EM.empty
  , lproj = EM.empty
  , ltile = unknownTileMap (fromJust (toArea (0,0,0,0))) unknownId 10 10  --PointArray.empty
  , lentry = EM.empty
  , larea = trivialArea (Point 0 0)
  , lsmell = EM.empty
  , lstair = ([],[])
  , lescape = []
  , lseen = 0
  , lexpl = 0
  , ltime = timeZero
  , lnight = False
  }

-- * Stub identifiers

-- Using different arbitrary numbers for these so that if tests fail
-- due to missing keys we'll have more of a clue.
testLevelId :: LevelId
testLevelId = toEnum 111

testActorId :: ActorId
testActorId = toEnum 112

testItemId :: ItemId
testItemId = toEnum 113

testFactionId :: FactionId
testFactionId = toEnum 114

-- * Game arena element stubs

testArea :: Area
testArea = fromJust(toArea (0, 0, 0, 0))

testLevelDimension :: Int
testLevelDimension = 3

stubLevel :: Level
stubLevel = Level
  { lkind = toEnum 0
  , ldepth = Dice.AbsDepth 1
  , lfloor = EM.empty
  , lembed = EM.empty
  , lbig = EM.empty
  , lproj = EM.empty
  , ltile = unknownTileMap testArea unknownId testLevelDimension testLevelDimension
  , lentry = EM.empty
  , larea = trivialArea (Point 0 0)
  , lsmell = EM.empty
  , lstair = ([],[])
  , lescape = []
  , lseen = 0
  , lexpl = 0
  , ltime = timeZero
  , lnight = False
  }
testFaction :: Faction
testFaction =
  Faction
    { gkind = emptyUIFaction
    , gname = ""
    , gcolor = Black
    , gdoctrine = Ability.TBlock
    , gunderAI = True
    , ginitial = []
    , gdipl = EM.empty
    , gquit = Nothing
    , _gleader = Nothing
    , gstash = Nothing
    , gvictims = EM.empty
    }

testActor :: Actor
testActor = Actor
  { btrunk = testItemId
  , bnumber = Nothing
  , bhp = 0
  , bhpDelta = ResDelta (0,0) (0,0)
  , bcalm = 0
  , bcalmDelta = ResDelta (0,0) (0,0)
  , bpos = Point 0 0
  , boldpos = Nothing
  , blid = testLevelId
  , bfid = testFactionId
  , btrajectory = Nothing
  , borgan = EM.empty
  , beqp = EM.empty
  , bweapon = 0
  , bweapBenign = 0
  , bwatch = WWatch
  , bproj = False
  }

testActorWithItem :: Actor
testActorWithItem =
  testActor { beqp = EM.singleton testItemId (1,[])}

-- Stublike state that should barely function for testing.
stubState :: State
stubState =
  let singletonFactionUpdate _ = EM.singleton testFactionId testFaction
      singletonDungeonUpdate _ = EM.singleton testLevelId stubLevel
      singletonActorDUpdate _ = EM.singleton testActorId testActor
      singletonActorMaxSkillsUpdate _ =
        EM.singleton testActorId Ability.zeroSkills
      copsUpdate oldCOps =
        oldCOps {corule = (corule oldCOps)
                   { rWidthMax = testLevelDimension
                   , rHeightMax = testLevelDimension }}
      stateWithMaxLevelDimension = updateCOpsAndCachedData copsUpdate emptyState
      stateWithFaction =
        updateFactionD singletonFactionUpdate stateWithMaxLevelDimension
      stateWithActorD = updateActorD singletonActorDUpdate stateWithFaction
      stateWithActorMaxSkills =
        updateActorMaxSkills singletonActorMaxSkillsUpdate stateWithActorD
      stateWithDungeon =
        updateDungeon singletonDungeonUpdate stateWithActorMaxSkills
  in stateWithDungeon

testStateWithItem :: State
testStateWithItem =
  let swapToItemActor _ = EM.singleton testActorId testActorWithItem
  in updateActorD swapToItemActor stubState

emptyCliState :: CliState
emptyCliState = CliState
  { cliState = emptyState
  , cliClient = emptyStateClient testFactionId
  , cliSession = Nothing
  }

stubSessionUI :: SessionUI
stubSessionUI =
  let actorUI = ActorUI { bsymbol = 'j'
                        , bname = "Jamie"
                        , bpronoun = "he/him"
                        , bcolor = BrCyan }
  in (emptySessionUI stubUIOptions)
    { sactorUI = EM.singleton testActorId actorUI
    , sccui = emptyCCUI { coscreen = emptyScreenContent
                                       { rwidth = testLevelDimension
                                       , rheight = testLevelDimension + 3 } }
    , schanF = fchanFrontendStub
    }

stubCliState :: CliState
stubCliState = CliState
  { cliState = stubState
  , cliClient = (emptyStateClient testFactionId)
      { soptions = stubClientOptions
      , sfper = EM.singleton testLevelId emptyPer }
  , cliSession = let target = TPoint TUnknown testLevelId (Point 1 0)
                 in Just (stubSessionUI {sxhair = Just target})
  }

testCliStateWithItem :: CliState
testCliStateWithItem = stubCliState { cliState = testStateWithItem }


-- * Monad harness mock

-- | Client state transformation monad mock.
newtype CliMock a = CliMock
  { runCliMock :: StateT CliState IO a }
    -- we build off io so we can compile but we don't want to use it;
    -- TODO: let's try to get rid of the IO. I can't see any problem right now.
    -- We'd need to to define dummy liftIO in some monads, etc.
  deriving (Monad, Functor, Applicative)

instance MonadStateRead CliMock where
  {-# INLINE getsState #-}
  getsState f = CliMock $ gets $ f . cliState

instance MonadStateWrite CliMock where
  {-# INLINE modifyState #-}
  modifyState f = CliMock $ state $ \cliS ->
    let !newCliS = cliS {cliState = f $ cliState cliS}
    in ((), newCliS)
  {-# INLINE putState #-}
  putState newCliState = CliMock $ state $ \cliS ->
    let !newCliS = cliS {cliState = newCliState}
    in ((), newCliS)

instance MonadClientRead CliMock where
  {-# INLINE getsClient #-}
  getsClient f = CliMock $ gets $ f . cliClient
  liftIO = CliMock . IO.liftIO

instance MonadClient CliMock where
  {-# INLINE modifyClient #-}
  modifyClient f = CliMock $ state $ \cliS ->
    let !newCliS = cliS {cliClient = f $ cliClient cliS}
    in ((), newCliS)

instance MonadClientUI CliMock where
  {-# INLINE getsSession #-}
  getsSession f = CliMock $ gets $ f . fromJust . cliSession
  {-# INLINE modifySession #-}
  modifySession f = CliMock $ state $ \cliS ->
    let !newCliSession = f $ fromJust $ cliSession cliS
        !newCliS = cliS {cliSession = Just newCliSession}
    in ((), newCliS)
  updateClientLeader aid = do
    s <- getState
    modifyClient $ updateLeader aid s
  getCacheBfs = BfsM.getCacheBfs
  getCachePath = BfsM.getCachePath

instance MonadClientAtomic CliMock where
  {-# INLINE execUpdAtomic #-}
  execUpdAtomic _ = return ()  -- handleUpdAtomic, until needed, save resources
    -- Don't catch anything; assume exceptions impossible.
  {-# INLINE execPutState #-}
  execPutState = putState

executorCli :: CliMock a -> CliState -> IO (a, CliState)
executorCli = runStateT . runCliMock


-- | Transform 'Report' type to a list of 'Text'.
reportToTexts :: Report -> [Text.Text]
reportToTexts report = Text.pack . attrStringToString <$> renderReport False report