-- | Debug output for requests and responses.
module Game.LambdaHack.Server.DebugM
  ( debugResponse
  , debugRequestAI, debugRequestUI
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , debugShow, debugPretty, debugPlain, DebugAid(..), debugAid
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Data.Int (Int64)
import qualified Data.Text as T
import qualified Text.Show.Pretty as Show.Pretty

import Game.LambdaHack.Atomic
import Game.LambdaHack.Client (Response (..))
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.State

-- We debug these on the server, not on the clients, because we want
-- a single log, knowing the order in which the server received requests
-- and sent responseQs. Clients interleave and block non-deterministically
-- so their logs would be harder to interpret.

debugShow :: Show a => a -> Text
debugShow :: forall a. Show a => a -> Text
debugShow = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
Show.Pretty.ppShow

debugResponse :: MonadServer m => FactionId -> Response -> m ()
debugResponse :: forall (m :: * -> *).
MonadServer m =>
FactionId -> Response -> m ()
debugResponse FactionId
fid Response
resp = case Response
resp of
  RespUpdAtomic State
_ cmd :: UpdAtomic
cmd@UpdPerception{} -> FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
"RespUpdAtomic" UpdAtomic
cmd
  RespUpdAtomic State
_ cmd :: UpdAtomic
cmd@UpdResume{} -> FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
"RespUpdAtomic" UpdAtomic
cmd
  RespUpdAtomic State
_ cmd :: UpdAtomic
cmd@UpdRestart{} -> FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
"RespUpdAtomic" UpdAtomic
cmd
  RespUpdAtomic State
_ cmd :: UpdAtomic
cmd@UpdSpotTile{} -> FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
"RespUpdAtomic" UpdAtomic
cmd
  RespUpdAtomic State
_ cmd :: UpdAtomic
cmd@(UpdCreateActor ActorId
aid Actor
_ [(ItemId, Item)]
_) -> do
    d <- ActorId -> Text -> m Text
forall (m :: * -> *). MonadServer m => ActorId -> Text -> m Text
debugAid ActorId
aid Text
"UpdCreateActor"
    serverPrint d
    debugPretty fid "RespUpdAtomic" cmd
  RespUpdAtomic State
_ cmd :: UpdAtomic
cmd@(UpdSpotActor ActorId
aid Actor
_) -> do
    d <- ActorId -> Text -> m Text
forall (m :: * -> *). MonadServer m => ActorId -> Text -> m Text
debugAid ActorId
aid Text
"UpdSpotActor"
    serverPrint d
    debugPretty fid "RespUpdAtomic" cmd
  RespUpdAtomic State
_ UpdAtomic
cmd -> FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPretty FactionId
fid Text
"RespUpdAtomic" UpdAtomic
cmd
  RespUpdAtomicNoState cmd :: UpdAtomic
cmd@UpdPerception{} ->
    FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
"RespUpdAtomicNoState" UpdAtomic
cmd
  RespUpdAtomicNoState cmd :: UpdAtomic
cmd@UpdResume{} ->
    FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
"RespUpdAtomicNoState" UpdAtomic
cmd
  RespUpdAtomicNoState cmd :: UpdAtomic
cmd@UpdSpotTile{} ->
    FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
"RespUpdAtomicNoState" UpdAtomic
cmd
  RespUpdAtomicNoState UpdAtomic
cmd ->
    FactionId -> Text -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPretty FactionId
fid Text
"RespUpdAtomicNoState" UpdAtomic
cmd
  RespQueryAI ActorId
aid -> do
    d <- ActorId -> Text -> m Text
forall (m :: * -> *). MonadServer m => ActorId -> Text -> m Text
debugAid ActorId
aid Text
"RespQueryAI"
    serverPrint d
  RespSfxAtomic SfxAtomic
sfx -> do  -- not so crucial so no details
    ps <- SfxAtomic -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => SfxAtomic -> m PosAtomic
posSfxAtomic SfxAtomic
sfx
    serverPrint $ debugShow (fid, "RespSfxAtomic" :: Text, ps)
  Response
RespQueryUIunderAI -> Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
serverPrint Text
"RespQueryUIunderAI"
  Response
RespQueryUI -> Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
serverPrint Text
"RespQueryUI"

debugPretty :: MonadServer m => FactionId -> Text -> UpdAtomic -> m ()
debugPretty :: forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPretty FactionId
fid Text
t UpdAtomic
cmd = do
  ps <- UpdAtomic -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => UpdAtomic -> m PosAtomic
posUpdAtomic UpdAtomic
cmd
  serverPrint $ debugShow (fid, t, ps, cmd)

debugPlain :: MonadServer m => FactionId -> Text -> UpdAtomic -> m ()
debugPlain :: forall (m :: * -> *).
MonadServer m =>
FactionId -> Text -> UpdAtomic -> m ()
debugPlain FactionId
fid Text
t UpdAtomic
cmd = do
  ps <- UpdAtomic -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => UpdAtomic -> m PosAtomic
posUpdAtomic UpdAtomic
cmd
  serverPrint $ T.pack $ show (fid, t, ps, cmd)
    -- too large for pretty printing

debugRequestAI :: MonadServer m => ActorId -> m ()
debugRequestAI :: forall (m :: * -> *). MonadServer m => ActorId -> m ()
debugRequestAI ActorId
aid = do
  d <- ActorId -> Text -> m Text
forall (m :: * -> *). MonadServer m => ActorId -> Text -> m Text
debugAid ActorId
aid Text
"AI request"
  serverPrint d

debugRequestUI :: MonadServer m => ActorId -> m ()
debugRequestUI :: forall (m :: * -> *). MonadServer m => ActorId -> m ()
debugRequestUI ActorId
aid = do
  d <- ActorId -> Text -> m Text
forall (m :: * -> *). MonadServer m => ActorId -> Text -> m Text
debugAid ActorId
aid Text
"UI request"
  serverPrint d

data DebugAid = DebugAid
  { DebugAid -> Text
label   :: Text
  , DebugAid -> ActorId
aid     :: ActorId
  , DebugAid -> FactionId
faction :: FactionId
  , DebugAid -> LevelId
lid     :: LevelId
  , DebugAid -> Int64
bHP     :: Int64
  , DebugAid -> Maybe Time
btime   :: Maybe Time
  , DebugAid -> Maybe Time
btrTime :: Maybe Time
  , DebugAid -> Time
time    :: Time
  }
  deriving Int -> DebugAid -> ShowS
[DebugAid] -> ShowS
DebugAid -> String
(Int -> DebugAid -> ShowS)
-> (DebugAid -> String) -> ([DebugAid] -> ShowS) -> Show DebugAid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugAid -> ShowS
showsPrec :: Int -> DebugAid -> ShowS
$cshow :: DebugAid -> String
show :: DebugAid -> String
$cshowList :: [DebugAid] -> ShowS
showList :: [DebugAid] -> ShowS
Show

debugAid :: MonadServer m => ActorId -> Text -> m Text
debugAid :: forall (m :: * -> *). MonadServer m => ActorId -> Text -> m Text
debugAid ActorId
aid Text
label = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  time <- getsState $ getLocalTime (blid b)
  btime <- getsServer $ lookupActorTime (bfid b) (blid b) aid . sactorTime
  btrTime <- getsServer $ lookupActorTime (bfid b) (blid b) aid . strajTime
  return $! debugShow DebugAid { label
                               , aid
                               , faction = bfid b
                               , lid = blid b
                               , bHP = bhp b
                               , btime
                               , btrTime
                               , time }