module Game.Antisplice.Terminal.Repl where
import Text.Chatty.Printer
import Text.Chatty.Scanner
import Text.Chatty.Interactor
import Text.Chatty.Expansion
import Text.Chatty.Extended.Printer
import System.Chatty.Misc
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad.Vocab
import Game.Antisplice.Monad
import Game.Antisplice.Errors
import Game.Antisplice.Lang
import Game.Antisplice.Utils.Fail
import Game.Antisplice.Utils.Counter
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Utils.Atoms
import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Data.Time.Clock
import System.Console.Haskeline
import System.Console.Haskeline.History
repl :: (ExtendedPrinter m,MonadScanner m,MonadError SplErr m,MonadIO m,MonadExpand m,ExpanderEnv m,MonadDungeon m,MonadAtoms m,MonadRoom m,MonadClock m,MonadVocab m) => m ()
repl = do
mv <- liftIO (newEmptyMVar :: IO (MVar (Maybe String)))
cont <- liftIO (newEmptyMVar :: IO (MVar ()))
thr <- liftIO $ forkOS $ runInputT defaultSettings{autoAddHistory=True} $ forever $ do
liftIO $ takeMVar cont
rl <- getInputLine "> "
liftIO $ putMVar mv rl
liftIO $ putMVar cont ()
forever $ do
e <- runFailT $ forever $ do
ds <- getDungeonState
now <- mgetstamp
let ts = takeWhile ((<now).fst) $ avlInorder $ timeTriggersOf ds
putDungeonState ds{timeTriggersOf=foldr avlRemove (timeTriggersOf ds) $ map fst ts}
forM_ ts (runTrigger . snd)
r <- liftIO $ tryTakeMVar mv
case r of
Just (Just l) -> do
l' <- expand l
e <- runFailT (act l')
case e of
Right _ -> return ()
Left VerbMustFirstError -> mprintLn "Please start with a verb."
Left UnintellegibleError -> mprintLn "I don't understand that."
Left CantWalkThereError -> mprintLn "I can't walk there."
Left WhichOneError -> mprintLn "Which one do you mean?"
Left CantSeeOneError -> mprintLn "I can't see one here."
Left e -> throwError e
throwError DoneError
Just Nothing -> liftIO (killThread thr) >> mprintLn "quit" >> throwError QuitError
Nothing -> liftIO $ threadDelay 100
case e of
Left DoneError -> liftIO $ putMVar cont ()
Left e -> throwError e