module Game.LambdaHack.Action.ActionLift
(
ActionFun, Action, liftIO, handlerToIO, withPerception, getPerception
, ActionFrame, returnNoFrame, returnFrame, whenFrame, inFrame
, Session(..), getFrontendSession, getCOps, getBinding, getOrigConfig
, abort, abortWith, abortIfWith, neverMind
, tryWith, tryRepeatedlyWith, tryIgnore
, getDiary, msgAdd, historyReset, msgReset
) where
import Control.Monad.State hiding (State, state, liftIO)
import qualified Data.List as L
import Data.Maybe
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Perception
import Game.LambdaHack.Action.Frontend
import Game.LambdaHack.Msg
import Game.LambdaHack.State
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Binding
import qualified Game.LambdaHack.Config as Config
import Game.LambdaHack.Animation (SingleFrame(..))
type ActionFun r a =
Session
-> DungeonPerception
-> (State -> Diary -> a -> IO r)
-> (Msg -> IO r)
-> State
-> Diary
-> IO r
newtype Action a = Action
{ runAction :: forall r . ActionFun r a
}
instance Show (Action a) where
show _ = "an action"
instance Monad Action where
return = returnAction
(>>=) = bindAction
instance Functor Action where
fmap f (Action g) = Action (\ s p k a st ms ->
let k' st' ms' = k st' ms' . f
in g s p k' a st ms)
instance MonadState State Action where
get = Action (\ _s _p k _a st ms -> k st ms st)
put nst = Action (\ _s _p k _a _st ms -> k nst ms ())
returnAction :: a -> Action a
returnAction x = Action (\ _s _p k _a st m -> k st m x)
bindAction :: Action a -> (a -> Action b) -> Action b
bindAction m f = Action (\ s p k a st ms ->
let next nst nm x =
runAction (f x) s p k a nst nm
in runAction m s p next a st ms)
liftIO :: IO a -> Action a
liftIO x = Action (\ _s _p k _a st ms -> x >>= k st ms)
handlerToIO :: Session -> State -> Diary -> Action () -> IO ()
handlerToIO sess@Session{scops} state diary h =
runAction h
sess
(dungeonPerception scops state)
(\ _ _ x -> return x)
(\ msg ->
ioError $ userError $ "unhandled abort " ++ msg)
state
diary
withPerception :: Action () -> Action ()
withPerception h =
Action (\ sess@Session{scops} _ k a st ms ->
runAction h sess (dungeonPerception scops st) k a st ms)
getPerception :: Action Perception
getPerception = Action (\ _s per k _a s ms ->
k s ms (fromJust $ L.lookup (slid s) per))
type ActionFrame a = Action (a, [Maybe SingleFrame])
returnNoFrame :: a -> ActionFrame a
returnNoFrame a = return (a, [])
returnFrame :: SingleFrame -> ActionFrame ()
returnFrame fr = return ((), [Just fr])
whenFrame :: Bool -> ActionFrame () -> ActionFrame ()
whenFrame True x = x
whenFrame False _ = returnNoFrame ()
inFrame :: Action () -> ActionFrame ()
inFrame act = act >> returnNoFrame ()
data Session = Session
{ sfs :: FrontendSession
, scops :: Kind.COps
, sbinding :: Binding (ActionFrame ())
, sorigConfig :: Config.CP
}
getFrontendSession :: Action FrontendSession
getFrontendSession = Action (\ Session{sfs} _p k _a st ms -> k st ms sfs)
getCOps :: Action Kind.COps
getCOps = Action (\ Session{scops} _p k _a st ms -> k st ms scops)
getBinding :: Action (Binding (ActionFrame ()))
getBinding = Action (\ Session{sbinding} _p k _a st ms -> k st ms sbinding)
getOrigConfig :: Action (Config.CP)
getOrigConfig =
Action (\ Session{sorigConfig} _p k _a st ms -> k st ms sorigConfig)
abort :: Action a
abort = abortWith ""
abortWith :: Msg -> Action a
abortWith msg = Action (\ _s _p _k a _st _ms -> a msg)
abortIfWith :: Bool -> Msg -> Action a
abortIfWith True msg = abortWith msg
abortIfWith False _ = abortWith ""
neverMind :: Bool -> Action a
neverMind b = abortIfWith b "never mind"
tryWith :: (Msg -> Action a) -> Action a -> Action a
tryWith exc h = Action (\ s p k a st ms ->
let runA msg = runAction (exc msg) s p k a st ms
in runAction h s p k runA st ms)
tryRepeatedlyWith :: (Msg -> Action ()) -> Action () -> Action ()
tryRepeatedlyWith exc h =
tryWith (\ msg -> exc msg >> tryRepeatedlyWith exc h) h
tryIgnore :: Action () -> Action ()
tryIgnore =
tryWith (\ msg -> if null msg
then return ()
else assert `failure` (msg, "in tryIgnore"))
getDiary :: Action Diary
getDiary = Action (\ _s _p k _a st diary -> k st diary diary)
msgAdd :: Msg -> Action ()
msgAdd nm = Action (\ _s _p k _a st ms ->
k st ms{sreport = addMsg (sreport ms) nm} ())
historyReset :: History -> Action ()
historyReset shistory = Action (\ _s _p k _a st Diary{sreport} ->
k st Diary{..} ())
msgReset :: Msg -> Action ()
msgReset nm = Action (\ _s _p k _a st ms ->
k st ms{sreport = singletonReport nm} ())