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

module Terminal.Game.Layer.Object.Narrate where

-- Record Monad, for when I need to play the game and record Events
-- (keypresses and ticks) in a file

import Terminal.Game.Layer.Object.Interface
import Terminal.Game.Layer.Object.IO

import qualified Control.Concurrent   as CC
import qualified Control.Monad        as CM
import qualified Control.Monad.Catch  as MC
import qualified Control.Monad.Reader as R
import qualified Control.Monad.Trans  as T -- MonadIO
import qualified Data.ByteString      as BS
import qualified Data.Serialize       as S
import qualified System.IO            as SI


newtype Narrate a = Narrate (R.ReaderT [Event] IO a)
                deriving (a -> Narrate b -> Narrate a
(a -> b) -> Narrate a -> Narrate b
(forall a b. (a -> b) -> Narrate a -> Narrate b)
-> (forall a b. a -> Narrate b -> Narrate a) -> Functor Narrate
forall a b. a -> Narrate b -> Narrate a
forall a b. (a -> b) -> Narrate a -> Narrate b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Narrate b -> Narrate a
$c<$ :: forall a b. a -> Narrate b -> Narrate a
fmap :: (a -> b) -> Narrate a -> Narrate b
$cfmap :: forall a b. (a -> b) -> Narrate a -> Narrate b
Functor, Functor Narrate
a -> Narrate a
Functor Narrate
-> (forall a. a -> Narrate a)
-> (forall a b. Narrate (a -> b) -> Narrate a -> Narrate b)
-> (forall a b c.
    (a -> b -> c) -> Narrate a -> Narrate b -> Narrate c)
-> (forall a b. Narrate a -> Narrate b -> Narrate b)
-> (forall a b. Narrate a -> Narrate b -> Narrate a)
-> Applicative Narrate
Narrate a -> Narrate b -> Narrate b
Narrate a -> Narrate b -> Narrate a
Narrate (a -> b) -> Narrate a -> Narrate b
(a -> b -> c) -> Narrate a -> Narrate b -> Narrate c
forall a. a -> Narrate a
forall a b. Narrate a -> Narrate b -> Narrate a
forall a b. Narrate a -> Narrate b -> Narrate b
forall a b. Narrate (a -> b) -> Narrate a -> Narrate b
forall a b c. (a -> b -> c) -> Narrate a -> Narrate b -> Narrate 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
<* :: Narrate a -> Narrate b -> Narrate a
$c<* :: forall a b. Narrate a -> Narrate b -> Narrate a
*> :: Narrate a -> Narrate b -> Narrate b
$c*> :: forall a b. Narrate a -> Narrate b -> Narrate b
liftA2 :: (a -> b -> c) -> Narrate a -> Narrate b -> Narrate c
$cliftA2 :: forall a b c. (a -> b -> c) -> Narrate a -> Narrate b -> Narrate c
<*> :: Narrate (a -> b) -> Narrate a -> Narrate b
$c<*> :: forall a b. Narrate (a -> b) -> Narrate a -> Narrate b
pure :: a -> Narrate a
$cpure :: forall a. a -> Narrate a
$cp1Applicative :: Functor Narrate
Applicative, Applicative Narrate
a -> Narrate a
Applicative Narrate
-> (forall a b. Narrate a -> (a -> Narrate b) -> Narrate b)
-> (forall a b. Narrate a -> Narrate b -> Narrate b)
-> (forall a. a -> Narrate a)
-> Monad Narrate
Narrate a -> (a -> Narrate b) -> Narrate b
Narrate a -> Narrate b -> Narrate b
forall a. a -> Narrate a
forall a b. Narrate a -> Narrate b -> Narrate b
forall a b. Narrate a -> (a -> Narrate b) -> Narrate 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 -> Narrate a
$creturn :: forall a. a -> Narrate a
>> :: Narrate a -> Narrate b -> Narrate b
$c>> :: forall a b. Narrate a -> Narrate b -> Narrate b
>>= :: Narrate a -> (a -> Narrate b) -> Narrate b
$c>>= :: forall a b. Narrate a -> (a -> Narrate b) -> Narrate b
$cp1Monad :: Applicative Narrate
Monad,
                          Monad Narrate
Monad Narrate -> (forall a. IO a -> Narrate a) -> MonadIO Narrate
IO a -> Narrate a
forall a. IO a -> Narrate a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Narrate a
$cliftIO :: forall a. IO a -> Narrate a
$cp1MonadIO :: Monad Narrate
T.MonadIO,
                          Monad Narrate
e -> Narrate a
Monad Narrate
-> (forall e a. Exception e => e -> Narrate a)
-> MonadThrow Narrate
forall e a. Exception e => e -> Narrate a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> Narrate a
$cthrowM :: forall e a. Exception e => e -> Narrate a
$cp1MonadThrow :: Monad Narrate
MC.MonadThrow, MonadThrow Narrate
MonadThrow Narrate
-> (forall e a.
    Exception e =>
    Narrate a -> (e -> Narrate a) -> Narrate a)
-> MonadCatch Narrate
Narrate a -> (e -> Narrate a) -> Narrate a
forall e a.
Exception e =>
Narrate a -> (e -> Narrate a) -> Narrate a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: Narrate a -> (e -> Narrate a) -> Narrate a
$ccatch :: forall e a.
Exception e =>
Narrate a -> (e -> Narrate a) -> Narrate a
$cp1MonadCatch :: MonadThrow Narrate
MC.MonadCatch, MonadCatch Narrate
MonadCatch Narrate
-> (forall b.
    ((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b)
-> (forall b.
    ((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b)
-> (forall a b c.
    Narrate a
    -> (a -> ExitCase b -> Narrate c)
    -> (a -> Narrate b)
    -> Narrate (b, c))
-> MonadMask Narrate
Narrate a
-> (a -> ExitCase b -> Narrate c)
-> (a -> Narrate b)
-> Narrate (b, c)
((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b
((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b
forall b.
((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b
forall a b c.
Narrate a
-> (a -> ExitCase b -> Narrate c)
-> (a -> Narrate b)
-> Narrate (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: Narrate a
-> (a -> ExitCase b -> Narrate c)
-> (a -> Narrate b)
-> Narrate (b, c)
$cgeneralBracket :: forall a b c.
Narrate a
-> (a -> ExitCase b -> Narrate c)
-> (a -> Narrate b)
-> Narrate (b, c)
uninterruptibleMask :: ((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b
$cuninterruptibleMask :: forall b.
((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b
mask :: ((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b
$cmask :: forall b.
((forall a. Narrate a -> Narrate a) -> Narrate b) -> Narrate b
$cp1MonadMask :: MonadCatch Narrate
MC.MonadMask)

runReplay :: Narrate a -> [Event] -> IO a
runReplay :: Narrate a -> [Event] -> IO a
runReplay (Narrate ReaderT [Event] IO a
r) [Event]
e = ReaderT [Event] IO a -> [Event] -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT ReaderT [Event] IO a
r [Event]
e

-- | Reads a file containing a recorded session.
readRecord :: FilePath -> IO [Event]
readRecord :: FilePath -> IO [Event]
readRecord FilePath
fp = ByteString -> Either FilePath [Event]
forall a. Serialize a => ByteString -> Either FilePath a
S.decode (ByteString -> Either FilePath [Event])
-> IO ByteString -> IO (Either FilePath [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
fp IO (Either FilePath [Event])
-> (Either FilePath [Event] -> IO [Event]) -> IO [Event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Left FilePath
e  -> FilePath -> IO [Event]
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO [Event]) -> FilePath -> IO [Event]
forall a b. (a -> b) -> a -> b
$ FilePath
"readRecord could not decode: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                     FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
e
                  Right [Event]
r -> [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [Event]
r

instance MonadInput Narrate where
    startEvents :: FPS -> Narrate InputHandle
startEvents FPS
fps = ReaderT [Event] IO InputHandle -> Narrate InputHandle
forall a. ReaderT [Event] IO a -> Narrate a
Narrate (ReaderT [Event] IO InputHandle -> Narrate InputHandle)
-> ReaderT [Event] IO InputHandle -> Narrate InputHandle
forall a b. (a -> b) -> a -> b
$
                        ReaderT [Event] IO [Event]
forall r (m :: * -> *). MonadReader r m => m r
R.ask ReaderT [Event] IO [Event]
-> ([Event] -> ReaderT [Event] IO InputHandle)
-> ReaderT [Event] IO InputHandle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Event]
e ->
                        IO InputHandle -> ReaderT [Event] IO InputHandle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO InputHandle -> ReaderT [Event] IO InputHandle)
-> IO InputHandle -> ReaderT [Event] IO InputHandle
forall a b. (a -> b) -> a -> b
$ [Event] -> FPS -> IO InputHandle
startNarrate [Event]
e FPS
fps
    pollEvents :: MVar [Event] -> Narrate [Event]
pollEvents MVar [Event]
ve = IO [Event] -> Narrate [Event]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO [Event] -> Narrate [Event]) -> IO [Event] -> Narrate [Event]
forall a b. (a -> b) -> a -> b
$ MVar [Event] -> [Event] -> IO [Event]
forall a. MVar a -> a -> IO a
CC.swapMVar MVar [Event]
ve []
    stopEvents :: [ThreadId] -> Narrate ()
stopEvents [ThreadId]
ts = IO () -> Narrate ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
T.liftIO (IO () -> Narrate ()) -> IO () -> Narrate ()
forall a b. (a -> b) -> a -> b
$ [ThreadId] -> IO ()
stopEventsIO [ThreadId]
ts
        -- xxx questi puoi fare dispatch tramite TC?

-- xxx ma narrate deve finire?
instance MonadLogic Narrate where
    checkQuit :: (s -> Bool) -> s -> Narrate Bool
checkQuit s -> Bool
fs s
s = ReaderT [Event] IO Bool -> Narrate Bool
forall a. ReaderT [Event] IO a -> Narrate a
Narrate (ReaderT [Event] IO Bool -> Narrate Bool)
-> ReaderT [Event] IO Bool -> Narrate Bool
forall a b. (a -> b) -> a -> b
$ ReaderT [Event] IO [Event]
forall r (m :: * -> *). MonadReader r m => m r
R.ask ReaderT [Event] IO [Event]
-> ([Event] -> ReaderT [Event] IO Bool) -> ReaderT [Event] IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                         [] -> Bool -> ReaderT [Event] IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         [Event]
_  -> Bool -> ReaderT [Event] IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ReaderT [Event] IO Bool)
-> Bool -> ReaderT [Event] IO Bool
forall a b. (a -> b) -> a -> b
$ s -> Bool
fs s
s




-- xxx astrai da qui?
-- filepath = logging
startNarrate :: [Event] -> FPS -> IO InputHandle
startNarrate :: [Event] -> FPS -> IO InputHandle
startNarrate [Event]
env FPS
fps =

                   -- non buffered input
                   Handle -> BufferMode -> IO ()
SI.hSetBuffering Handle
SI.stdin BufferMode
SI.NoBuffering  IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                   Handle -> BufferMode -> IO ()
SI.hSetBuffering Handle
SI.stdout BufferMode
SI.NoBuffering IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                   Handle -> Bool -> IO ()
SI.hSetEcho Handle
SI.stdin Bool
False                IO () -> IO (MVar [Event]) -> IO (MVar [Event])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                   -- xxx astrai this

                   [Event] -> IO (MVar [Event])
forall a. a -> IO (MVar a)
CC.newMVar []                 IO (MVar [Event])
-> (MVar [Event] -> IO InputHandle) -> IO InputHandle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MVar [Event]
ve ->
                   IO () -> IO ThreadId
CC.forkIO (MVar [Event] -> [Event] -> FPS -> IO ()
addEnv MVar [Event]
ve [Event]
env FPS
fps) IO ThreadId -> (ThreadId -> IO InputHandle) -> IO InputHandle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ThreadId
te ->
                   InputHandle -> IO InputHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar [Event] -> [ThreadId] -> InputHandle
InputHandle MVar [Event]
ve [ThreadId
te])

addEnv :: CC.MVar [Event] -> [Event] -> FPS -> IO ()
addEnv :: MVar [Event] -> [Event] -> FPS -> IO ()
addEnv MVar [Event]
_  []     FPS
_   = FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"fine"
                        -- xxx occhio qui, error or throwIO? Which message?
addEnv MVar [Event]
ve (Event
e:[Event]
es) FPS
fps = Maybe (MVar [Event]) -> MVar [Event] -> Event -> IO ()
addEvent Maybe (MVar [Event])
forall a. Maybe a
Nothing MVar [Event]
ve Event
e IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
CM.when (Event
e Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
Tick)
                            (Int -> IO ()
CC.threadDelay Int
delayAmount) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       MVar [Event] -> [Event] -> FPS -> IO ()
addEnv MVar [Event]
ve [Event]
es FPS
fps
    where
          delayAmount :: Int
          delayAmount :: Int
delayAmount = FPS -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FPS -> Int) -> FPS -> Int
forall a b. (a -> b) -> a -> b
$ FPS -> FPS -> FPS
forall a. Integral a => a -> a -> a
quot FPS
oneTickSec FPS
fps