68 lines
2.1 KiB
Haskell
68 lines
2.1 KiB
Haskell
module Dodge.Concurrent (
|
|
hardQuit,
|
|
addSideEffect,
|
|
conEffects,
|
|
blockingLoad,
|
|
) where
|
|
|
|
import Data.Sequence (Seq (..))
|
|
import Dodge.Data.Universe
|
|
import LensHelp
|
|
|
|
conEffects :: Universe -> ConcurrentEffect Universe
|
|
conEffects u = case u ^? uvSideEffects . _head of
|
|
Just NewSideEffect{_ceSideEffect = eff} ->
|
|
ConcurrentEffect
|
|
(u & uvSideEffects . _head %~ g)
|
|
(dopop eff)
|
|
Just HardQuit -> ImmediateEffect (return Nothing)
|
|
_ -> NoConcurrentEffect
|
|
where
|
|
g seff = RunningSideEffect (_ceString seff)
|
|
dopop :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)
|
|
dopop mf = do
|
|
f <- mf
|
|
return $ f . (uvSideEffects %~ taker)
|
|
taker (_ :<| xs) = xs
|
|
taker _ = mempty
|
|
|
|
addSideEffect :: IO (Universe -> Maybe Universe) -> String -> Universe -> Universe
|
|
addSideEffect f s = uvSideEffects %~ (|> NewSideEffect f s)
|
|
|
|
hardQuit :: Universe -> Universe
|
|
hardQuit = uvSideEffects %~ (HardQuit <|)
|
|
|
|
blockingLoad :: String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
|
|
blockingLoad str f u =
|
|
u & uvScreenLayers .:~ loadingScreen str
|
|
& addSideEffect f str
|
|
|
|
--hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
|
|
|
|
--tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
|
|
--tryConcEffect bl str eff u = case u ^. uvConcEffects of
|
|
-- NoConcEffect -> u & uvConcEffects .~ NewConcEffect (ConcurrentEffect setstr (clearConcEff eff)) str bl
|
|
-- _ -> u
|
|
-- where
|
|
-- setstr
|
|
-- | bl = uvConcEffects .~ BlockingConcEffect str
|
|
-- | otherwise = uvConcEffects .~ BackgroundConcEffect str
|
|
|
|
--clearConcEff :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)
|
|
--clearConcEff eff = do
|
|
-- f <- eff
|
|
-- return (f . (uvConcEffects .~ NoConcEffect))
|
|
|
|
loadingScreen :: String -> ScreenLayer
|
|
loadingScreen str =
|
|
OptionScreen
|
|
{ _scTitle = str
|
|
, _scOptions = mempty
|
|
, _scOffset = 0
|
|
, _scPositionedMenuOption = NoEscapeMenuOption
|
|
, _scOptionFlag = LoadingScreen
|
|
, _scSelectionList = mempty
|
|
, _scAvailableLines = 0
|
|
, _scDisplayTime = 0
|
|
}
|