{-# LANGUAGE FlexibleContexts, ImpredicativeTypes #-}

{-
  This module is part of Antisplice.
  Copyleft (c) 2014 Marvin Cohrs

  All wrongs reversed. Sharing is an act of love, not crime.
  Please share Antisplice with everyone you like.

  Antisplice is free software: you can redistribute it and/or modify
  it under the terms of the GNU Affero General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Antisplice is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  GNU Affero General Public License for more details.

  You should have received a copy of the GNU Affero General Public License
  along with Antisplice. If not, see <http://www.gnu.org/licenses/>.
-}

-- | Provides a haskeline-based Read Eval Print Loop.
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

-- | Read Eval Print Loop for Antisplice.
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