module Data.Component.MessageLayer where import Control.Lens import Control.Lens.TH.Rules import Control.Monad.State import Data.Aeson import Data.Typeable (Typeable) import Linear import MiniLight import qualified Data.Component.Basic as Basic import qualified Data.Component.Layer as CLayer import qualified Data.Component.AnimationLayer as CAnim import qualified Data.Component.MessageEngine as CME import qualified SDL.Vect as Vect data Config = Config { Config -> Config basic :: Basic.Config, Config -> Config engine :: CME.Config, Config -> Config window :: CLayer.Config, Config -> Config next :: CAnim.Config } instance FromJSON Config where parseJSON :: Value -> Parser Config parseJSON = String -> (Object -> Parser Config) -> Value -> Parser Config forall a. String -> (Object -> Parser a) -> Value -> Parser a withObject "config" ((Object -> Parser Config) -> Value -> Parser Config) -> (Object -> Parser Config) -> Value -> Parser Config forall a b. (a -> b) -> a -> b $ \v :: Object v -> do Config layerConf <- Value -> Parser Config forall a. FromJSON a => Value -> Parser a parseJSON (Value -> Parser Config) -> Parser Value -> Parser Config forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Object v Object -> Text -> Parser Value forall a. FromJSON a => Object -> Text -> Parser a .: "window" Config nextConf <- Value -> Parser Config forall a. FromJSON a => Value -> Parser a parseJSON (Value -> Parser Config) -> Parser Value -> Parser Config forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Object v Object -> Text -> Parser Value forall a. FromJSON a => Object -> Text -> Parser a .: "next" Config messageEngineConf <- Value -> Parser Config forall a. FromJSON a => Value -> Parser a parseJSON (Value -> Parser Config) -> Parser Value -> Parser Config forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Object v Object -> Text -> Parser Value forall a. FromJSON a => Object -> Text -> Parser a .: "engine" Config -> Parser Config forall (m :: * -> *) a. Monad m => a -> m a return (Config -> Parser Config) -> Config -> Parser Config forall a b. (a -> b) -> a -> b $ Config -> Config -> Config -> Config -> Config Config (Config layerConf Config -> Getting Config Config Config -> Config forall s a. s -> Getting a s a -> a ^. Getting Config Config Config forall c. HasConfig c => Lens' c Config Basic.config) Config messageEngineConf Config layerConf Config nextConf data MessageLayer = MessageLayer { MessageLayer -> MessageEngine messageEngine :: CME.MessageEngine, MessageLayer -> Layer layer :: CLayer.Layer, MessageLayer -> AnimationLayer cursor :: CAnim.AnimationLayer, MessageLayer -> Config config :: Config } makeLensesWith lensRules_ ''Config makeLensesWith lensRules_ ''MessageLayer instance Basic.HasConfig Config where config :: (Config -> f Config) -> Config -> f Config config = (Config -> f Config) -> Config -> f Config Lens' Config Config _basic engineL :: Lens' MessageLayer CME.MessageEngine engineL :: (MessageEngine -> f MessageEngine) -> MessageLayer -> f MessageLayer engineL = (MessageLayer -> MessageEngine) -> (MessageLayer -> MessageEngine -> MessageLayer) -> Lens MessageLayer MessageLayer MessageEngine MessageEngine forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b lens MessageLayer -> MessageEngine messageEngine (\s :: MessageLayer s a :: MessageEngine a -> MessageLayer s { messageEngine :: MessageEngine messageEngine = MessageEngine a }) cursorL :: Lens' MessageLayer CAnim.AnimationLayer cursorL :: (AnimationLayer -> f AnimationLayer) -> MessageLayer -> f MessageLayer cursorL = (MessageLayer -> AnimationLayer) -> (MessageLayer -> AnimationLayer -> MessageLayer) -> Lens MessageLayer MessageLayer AnimationLayer AnimationLayer forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b lens MessageLayer -> AnimationLayer cursor (\s :: MessageLayer s a :: AnimationLayer a -> MessageLayer s { cursor :: AnimationLayer cursor = AnimationLayer a }) data MessageLayerEvent where Finish :: MessageLayerEvent deriving Typeable instance EventType MessageLayerEvent where getEventType :: MessageLayerEvent -> Text getEventType Finish = "finish" instance ComponentUnit MessageLayer where update :: MessageLayer -> LightT env m MessageLayer update = StateT MessageLayer (LightT env m) () -> MessageLayer -> LightT env m MessageLayer forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s execStateT (StateT MessageLayer (LightT env m) () -> MessageLayer -> LightT env m MessageLayer) -> StateT MessageLayer (LightT env m) () -> MessageLayer -> LightT env m MessageLayer forall a b. (a -> b) -> a -> b $ do LensLike' (Zoomed (StateT MessageEngine (LightT env m)) ()) MessageLayer MessageEngine -> StateT MessageEngine (LightT env m) () -> StateT MessageLayer (LightT env m) () forall (m :: * -> *) (n :: * -> *) s t c. Zoom m n s t => LensLike' (Zoomed m c) t s -> m c -> n c zoom LensLike' (Zoomed (StateT MessageEngine (LightT env m)) ()) MessageLayer MessageEngine Lens MessageLayer MessageLayer MessageEngine MessageEngine engineL (StateT MessageEngine (LightT env m) () -> StateT MessageLayer (LightT env m) ()) -> StateT MessageEngine (LightT env m) () -> StateT MessageLayer (LightT env m) () forall a b. (a -> b) -> a -> b $ do MessageEngine c <- Getting MessageEngine MessageEngine MessageEngine -> StateT MessageEngine (LightT env m) MessageEngine forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a use Getting MessageEngine MessageEngine MessageEngine forall a. a -> a id (MessageEngine -> Identity MessageEngine) -> MessageEngine -> Identity MessageEngine forall a. a -> a id ((MessageEngine -> Identity MessageEngine) -> MessageEngine -> Identity MessageEngine) -> StateT MessageEngine (LightT env m) MessageEngine -> StateT MessageEngine (LightT env m) () forall s (m :: * -> *) a b. MonadState s m => ASetter s s a b -> m b -> m () <~ LightT env m MessageEngine -> StateT MessageEngine (LightT env m) MessageEngine forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (MessageEngine -> LightT env m MessageEngine forall c env (m :: * -> *). (ComponentUnit c, HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => c -> LightT env m c update MessageEngine c) LensLike' (Zoomed (StateT AnimationLayer (LightT env m)) ()) MessageLayer AnimationLayer -> StateT AnimationLayer (LightT env m) () -> StateT MessageLayer (LightT env m) () forall (m :: * -> *) (n :: * -> *) s t c. Zoom m n s t => LensLike' (Zoomed m c) t s -> m c -> n c zoom LensLike' (Zoomed (StateT AnimationLayer (LightT env m)) ()) MessageLayer AnimationLayer Lens MessageLayer MessageLayer AnimationLayer AnimationLayer cursorL (StateT AnimationLayer (LightT env m) () -> StateT MessageLayer (LightT env m) ()) -> StateT AnimationLayer (LightT env m) () -> StateT MessageLayer (LightT env m) () forall a b. (a -> b) -> a -> b $ do AnimationLayer c <- Getting AnimationLayer AnimationLayer AnimationLayer -> StateT AnimationLayer (LightT env m) AnimationLayer forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a use Getting AnimationLayer AnimationLayer AnimationLayer forall a. a -> a id (AnimationLayer -> Identity AnimationLayer) -> AnimationLayer -> Identity AnimationLayer forall a. a -> a id ((AnimationLayer -> Identity AnimationLayer) -> AnimationLayer -> Identity AnimationLayer) -> StateT AnimationLayer (LightT env m) AnimationLayer -> StateT AnimationLayer (LightT env m) () forall s (m :: * -> *) a b. MonadState s m => ASetter s s a b -> m b -> m () <~ LightT env m AnimationLayer -> StateT AnimationLayer (LightT env m) AnimationLayer forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (AnimationLayer -> LightT env m AnimationLayer forall c env (m :: * -> *). (ComponentUnit c, HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => c -> LightT env m c update AnimationLayer c) figures :: MessageLayer -> LightT env m [Figure] figures comp :: MessageLayer comp = do [Figure] baseLayer <- Layer -> LightT env m [Figure] forall c env (m :: * -> *). (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m [Figure] figures (Layer -> LightT env m [Figure]) -> Layer -> LightT env m [Figure] forall a b. (a -> b) -> a -> b $ MessageLayer -> Layer layer MessageLayer comp [Figure] cursorLayer <- AnimationLayer -> LightT env m [Figure] forall c env (m :: * -> *). (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m [Figure] figures (AnimationLayer -> LightT env m [Figure]) -> AnimationLayer -> LightT env m [Figure] forall a b. (a -> b) -> a -> b $ MessageLayer -> AnimationLayer cursor MessageLayer comp [Figure] textLayer <- MessageEngine -> LightT env m [Figure] forall c env (m :: * -> *). (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m [Figure] figures (MessageEngine -> LightT env m [Figure]) -> MessageEngine -> LightT env m [Figure] forall a b. (a -> b) -> a -> b $ MessageLayer -> MessageEngine messageEngine MessageLayer comp let cursorSize :: V2 Int cursorSize = AnimationLayer -> V2 Int CAnim.tileSize (MessageLayer -> AnimationLayer cursor MessageLayer comp) let windowSize :: V2 Int windowSize = Config -> V2 Int Basic.size (Config -> V2 Int) -> Config -> V2 Int forall a b. (a -> b) -> a -> b $ Config -> Config CLayer.basic (Config -> Config) -> Config -> Config forall a b. (a -> b) -> a -> b $ Config -> Config window (Config -> Config) -> Config -> Config forall a b. (a -> b) -> a -> b $ MessageLayer -> Config config MessageLayer comp let position :: V2 Int position = Config -> V2 Int Basic.position (Config -> V2 Int) -> Config -> V2 Int forall a b. (a -> b) -> a -> b $ Config -> Config CLayer.basic (Config -> Config) -> Config -> Config forall a b. (a -> b) -> a -> b $ Config -> Config window (Config -> Config) -> Config -> Config forall a b. (a -> b) -> a -> b $ MessageLayer -> Config config MessageLayer comp [Figure] -> LightT env m [Figure] forall (m :: * -> *) a. Monad m => a -> m a return ([Figure] -> LightT env m [Figure]) -> [Figure] -> LightT env m [Figure] forall a b. (a -> b) -> a -> b $ [Figure] baseLayer [Figure] -> [Figure] -> [Figure] forall a. [a] -> [a] -> [a] ++ (Figure -> Figure) -> [Figure] -> [Figure] forall a b. (a -> b) -> [a] -> [b] map (V2 Int -> Figure -> Figure forall r (m :: * -> *). Rendering r m => V2 Int -> r -> r translate (V2 Int position V2 Int -> V2 Int -> V2 Int forall a. Num a => a -> a -> a + Int -> Int -> V2 Int forall a. a -> a -> V2 a Vect.V2 20 10)) [Figure] textLayer [Figure] -> [Figure] -> [Figure] forall a. [a] -> [a] -> [a] ++ (Figure -> Figure) -> [Figure] -> [Figure] forall a b. (a -> b) -> [a] -> [b] map (V2 Int -> Figure -> Figure forall r (m :: * -> *). Rendering r m => V2 Int -> r -> r translate (V2 Int position V2 Int -> V2 Int -> V2 Int forall a. Num a => a -> a -> a + Int -> Int -> V2 Int forall a. a -> a -> V2 a Vect.V2 ((V2 Int windowSize V2 Int -> Getting Int (V2 Int) Int -> Int forall s a. s -> Getting a s a -> a ^. Getting Int (V2 Int) Int forall (t :: * -> *) a. R1 t => Lens' (t a) a _x Int -> Int -> Int forall a. Num a => a -> a -> a - V2 Int cursorSize V2 Int -> Getting Int (V2 Int) Int -> Int forall s a. s -> Getting a s a -> a ^. Getting Int (V2 Int) Int forall (t :: * -> *) a. R1 t => Lens' (t a) a _x) Int -> Int -> Int forall a. Integral a => a -> a -> a `div` 2) (V2 Int windowSize V2 Int -> Getting Int (V2 Int) Int -> Int forall s a. s -> Getting a s a -> a ^. Getting Int (V2 Int) Int forall (t :: * -> *) a. R2 t => Lens' (t a) a _y Int -> Int -> Int forall a. Num a => a -> a -> a - V2 Int cursorSize V2 Int -> Getting Int (V2 Int) Int -> Int forall s a. s -> Getting a s a -> a ^. Getting Int (V2 Int) Int forall (t :: * -> *) a. R2 t => Lens' (t a) a _y))) [Figure] cursorLayer onSignal :: Event -> MessageLayer -> LightT env m MessageLayer onSignal = Lens' MessageLayer Config -> (Event -> MessageLayer -> LightT env m MessageLayer) -> Event -> MessageLayer -> LightT env m MessageLayer forall env (m :: * -> *) c. (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, ComponentUnit c) => Lens' c Config -> (Event -> c -> LightT env m c) -> Event -> c -> LightT env m c Basic.wrapSignal ((Config -> f Config) -> MessageLayer -> f MessageLayer Lens' MessageLayer Config _config ((Config -> f Config) -> MessageLayer -> f MessageLayer) -> ((Config -> f Config) -> Config -> f Config) -> (Config -> f Config) -> MessageLayer -> f MessageLayer forall b c a. (b -> c) -> (a -> b) -> a -> c . (Config -> f Config) -> Config -> f Config forall c. HasConfig c => Lens' c Config Basic.config) ((Event -> MessageLayer -> LightT env m MessageLayer) -> Event -> MessageLayer -> LightT env m MessageLayer) -> (Event -> MessageLayer -> LightT env m MessageLayer) -> Event -> MessageLayer -> LightT env m MessageLayer forall a b. (a -> b) -> a -> b $ Lens MessageLayer MessageLayer MessageEngine MessageEngine -> (Event -> MessageLayer -> LightT env m MessageLayer) -> Event -> MessageLayer -> LightT env m MessageLayer forall env (m :: * -> *) c. (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => Lens' c MessageEngine -> (Event -> c -> LightT env m c) -> Event -> c -> LightT env m c CME.wrapSignal Lens MessageLayer MessageLayer MessageEngine MessageEngine _messageEngine ((Event -> MessageLayer -> LightT env m MessageLayer) -> Event -> MessageLayer -> LightT env m MessageLayer) -> (Event -> MessageLayer -> LightT env m MessageLayer) -> Event -> MessageLayer -> LightT env m MessageLayer forall a b. (a -> b) -> a -> b $ \ev :: Event ev -> StateT MessageLayer (LightT env m) () -> MessageLayer -> LightT env m MessageLayer forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s execStateT (StateT MessageLayer (LightT env m) () -> MessageLayer -> LightT env m MessageLayer) -> StateT MessageLayer (LightT env m) () -> MessageLayer -> LightT env m MessageLayer forall a b. (a -> b) -> a -> b $ case Event -> Maybe Signal forall a. EventType a => Event -> Maybe a asSignal Event ev of Just (Basic.MouseReleased _) -> do MessageEngine me <- Getting MessageEngine MessageLayer MessageEngine -> StateT MessageLayer (LightT env m) MessageEngine forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a use Getting MessageEngine MessageLayer MessageEngine Lens MessageLayer MessageLayer MessageEngine MessageEngine _messageEngine if MessageEngine me MessageEngine -> Getting Bool MessageEngine Bool -> Bool forall s a. s -> Getting a s a -> a ^. Getting Bool MessageEngine Bool Lens' MessageEngine Bool CME._finished then LightT env m () -> StateT MessageLayer (LightT env m) () forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (LightT env m () -> StateT MessageLayer (LightT env m) ()) -> LightT env m () -> StateT MessageLayer (LightT env m) () forall a b. (a -> b) -> a -> b $ MessageLayerEvent -> LightT env m () forall env (m :: * -> *) et. (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) => et -> LightT env m () emitGlobally MessageLayerEvent Finish else LightT env m () -> StateT MessageLayer (LightT env m) () forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (LightT env m () -> StateT MessageLayer (LightT env m) ()) -> LightT env m () -> StateT MessageLayer (LightT env m) () forall a b. (a -> b) -> a -> b $ EngineEvent -> LightT env m () forall env (m :: * -> *) et. (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) => et -> LightT env m () emitGlobally EngineEvent CME.NextPage _ -> () -> StateT MessageLayer (LightT env m) () forall (m :: * -> *) a. Monad m => a -> m a return () new :: Config -> MiniLight MessageLayer new :: Config -> MiniLight MessageLayer new conf :: Config conf = do MessageEngine engine <- Config -> MiniLight MessageEngine CME.new (Config -> Config engine Config conf) Layer layer <- Config -> MiniLight Layer CLayer.newNineTile (Config -> Config window Config conf) AnimationLayer cursor <- Config -> MiniLight AnimationLayer CAnim.new (Config -> Config next Config conf) MessageLayer -> MiniLight MessageLayer forall (m :: * -> *) a. Monad m => a -> m a return (MessageLayer -> MiniLight MessageLayer) -> MessageLayer -> MiniLight MessageLayer forall a b. (a -> b) -> a -> b $ $WMessageLayer :: MessageEngine -> Layer -> AnimationLayer -> Config -> MessageLayer MessageLayer { messageEngine :: MessageEngine messageEngine = MessageEngine engine , layer :: Layer layer = Layer layer , cursor :: AnimationLayer cursor = AnimationLayer cursor , config :: Config config = Config conf }