module Data.Component.Button where import Data.Aeson import qualified Data.Text as T import Data.Typeable import Data.Word (Word8) import MiniLight import qualified SDL import qualified SDL.Font import qualified SDL.Vect as Vect data Button = Button { Button -> Font font :: SDL.Font.Font, Button -> Config config :: Config } data ButtonEvent = Click deriving Typeable instance EventType ButtonEvent where getEventType :: ButtonEvent -> Text getEventType Click = "click" instance ComponentUnit Button where update :: Button -> LightT env m Button update = Button -> LightT env m Button forall (m :: * -> *) a. Monad m => a -> m a return figures :: Button -> LightT env m [Figure] figures comp :: Button comp = do Figure textTexture <- MiniLight Figure -> LightT env m Figure forall env (m :: * -> *) a. (HasLightEnv env, MonadIO m) => MiniLight a -> LightT env m a liftMiniLight (MiniLight Figure -> LightT env m Figure) -> MiniLight Figure -> LightT env m Figure forall a b. (a -> b) -> a -> b $ Font -> V4 Word8 -> Text -> MiniLight Figure forall r (m :: * -> *). Rendering r m => Font -> V4 Word8 -> Text -> m r text (Button -> Font font Button comp) (Config -> V4 Word8 color (Button -> Config config Button comp)) (Text -> MiniLight Figure) -> Text -> MiniLight Figure forall a b. (a -> b) -> a -> b $ Config -> Text label (Button -> Config config Button comp) Figure base <- MiniLight Figure -> LightT env m Figure forall env (m :: * -> *) a. (HasLightEnv env, MonadIO m) => MiniLight a -> LightT env m a liftMiniLight (MiniLight Figure -> LightT env m Figure) -> MiniLight Figure -> LightT env m Figure forall a b. (a -> b) -> a -> b $ V4 Word8 -> V2 Int -> MiniLight Figure forall r (m :: * -> *). Rendering r m => V4 Word8 -> V2 Int -> m r rectangleFilled (Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8 forall a. a -> a -> a -> a -> V4 a Vect.V4 200 200 200 255) (Figure -> V2 Int getFigureSize Figure textTexture) [Figure] -> LightT env m [Figure] forall (m :: * -> *) a. Monad m => a -> m a return [ Figure base, Figure textTexture ] useCache :: Button -> Button -> Bool useCache _ _ = Bool True onSignal :: Event -> Button -> LightT env m Button onSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ _ _ _)))) comp :: Button comp = do ButtonEvent -> LightT env m () forall env (m :: * -> *) et. (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) => et -> LightT env m () emitGlobally ButtonEvent Click Button -> LightT env m Button forall (m :: * -> *) a. Monad m => a -> m a return Button comp onSignal _ comp :: Button comp = Button -> LightT env m Button forall (m :: * -> *) a. Monad m => a -> m a return Button comp beforeClearCache :: Button -> [Figure] -> LightT env m () beforeClearCache _ figs :: [Figure] figs = (Figure -> LightT env m ()) -> [Figure] -> LightT env m () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Figure -> LightT env m () forall (m :: * -> *). MonadIO m => Figure -> m () freeFigure [Figure] figs data Config = Config { Config -> V2 Int size :: Vect.V2 Int, Config -> Text label :: T.Text, Config -> V4 Word8 color :: Vect.V4 Word8, Config -> FontDescriptor fontConf :: FontDescriptor, Config -> Int fontSize :: Int } 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 V2 Int size <- String -> (Object -> Parser (V2 Int)) -> Value -> Parser (V2 Int) forall a. String -> (Object -> Parser a) -> Value -> Parser a withObject "font" (\v :: Object v -> Int -> Int -> V2 Int forall a. a -> a -> V2 a Vect.V2 (Int -> Int -> V2 Int) -> Parser Int -> Parser (Int -> V2 Int) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Object v Object -> Text -> Parser Int forall a. FromJSON a => Object -> Text -> Parser a .: "width" Parser (Int -> V2 Int) -> Parser Int -> Parser (V2 Int) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Object v Object -> Text -> Parser Int forall a. FromJSON a => Object -> Text -> Parser a .: "height") (Value -> Parser (V2 Int)) -> Parser Value -> Parser (V2 Int) 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 .: "size" Text label <- Object v Object -> Text -> Parser Text forall a. FromJSON a => Object -> Text -> Parser a .: "label" [r :: Word8 r,g :: Word8 g,b :: Word8 b,a :: Word8 a] <- Object v Object -> Text -> Parser (Maybe [Word8]) forall a. FromJSON a => Object -> Text -> Parser (Maybe a) .:? "color" Parser (Maybe [Word8]) -> [Word8] -> Parser [Word8] forall a. Parser (Maybe a) -> a -> Parser a .!= [255, 255, 255, 255] (fontConf :: FontDescriptor fontConf, fontSize :: Int fontSize) <- (Object v Object -> Text -> Parser Value forall a. FromJSON a => Object -> Text -> Parser a .: "font" Parser Value -> (Value -> Parser (FontDescriptor, Int)) -> Parser (FontDescriptor, Int) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>=) ((Value -> Parser (FontDescriptor, Int)) -> Parser (FontDescriptor, Int)) -> (Value -> Parser (FontDescriptor, Int)) -> Parser (FontDescriptor, Int) forall a b. (a -> b) -> a -> b $ String -> (Object -> Parser (FontDescriptor, Int)) -> Value -> Parser (FontDescriptor, Int) forall a. String -> (Object -> Parser a) -> Value -> Parser a withObject "font" ((Object -> Parser (FontDescriptor, Int)) -> Value -> Parser (FontDescriptor, Int)) -> (Object -> Parser (FontDescriptor, Int)) -> Value -> Parser (FontDescriptor, Int) forall a b. (a -> b) -> a -> b $ \v :: Object v -> do Text family <- Object v Object -> Text -> Parser Text forall a. FromJSON a => Object -> Text -> Parser a .: "family" Int size <- Object v Object -> Text -> Parser Int forall a. FromJSON a => Object -> Text -> Parser a .: "size" Bool bold <- Object v Object -> Text -> Parser (Maybe Bool) forall a. FromJSON a => Object -> Text -> Parser (Maybe a) .:? "bold" Parser (Maybe Bool) -> Bool -> Parser Bool forall a. Parser (Maybe a) -> a -> Parser a .!= Bool False Bool italic <- Object v Object -> Text -> Parser (Maybe Bool) forall a. FromJSON a => Object -> Text -> Parser (Maybe a) .:? "italic" Parser (Maybe Bool) -> Bool -> Parser Bool forall a. Parser (Maybe a) -> a -> Parser a .!= Bool False (FontDescriptor, Int) -> Parser (FontDescriptor, Int) forall (m :: * -> *) a. Monad m => a -> m a return ((FontDescriptor, Int) -> Parser (FontDescriptor, Int)) -> (FontDescriptor, Int) -> Parser (FontDescriptor, Int) forall a b. (a -> b) -> a -> b $ (Text -> FontStyle -> FontDescriptor FontDescriptor Text family (Bool -> Bool -> FontStyle FontStyle Bool bold Bool italic), Int size) 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 $ V2 Int -> Text -> V4 Word8 -> FontDescriptor -> Int -> Config Config V2 Int size Text label (Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8 forall a. a -> a -> a -> a -> V4 a Vect.V4 Word8 r Word8 g Word8 b Word8 a) FontDescriptor fontConf Int fontSize new :: Config -> MiniLight Button new :: Config -> MiniLight Button new conf :: Config conf = do Font font <- FontDescriptor -> Int -> LightT LightEnv IO Font forall env (m :: * -> *). (HasLightEnv env, MonadIO m) => FontDescriptor -> Int -> LightT env m Font loadFont (Config -> FontDescriptor fontConf Config conf) (Config -> Int fontSize Config conf) Button -> MiniLight Button forall (m :: * -> *) a. Monad m => a -> m a return (Button -> MiniLight Button) -> Button -> MiniLight Button forall a b. (a -> b) -> a -> b $ $WButton :: Font -> Config -> Button Button {font :: Font font = Font font, config :: Config config = Config conf}