diff --git a/minilight.cabal b/minilight.cabal --- a/minilight.cabal +++ b/minilight.cabal @@ -3,7 +3,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/ name: minilight -version: 0.4.0 +version: 0.4.1 synopsis: A SDL2-based graphics library, batteries-included. description: This package provides the wheel for a graphical application or a game. @@ -67,20 +67,20 @@ vector >= 0.12.0 && < 0.13, aeson >= 1.4.2 && < 1.5, scientific >= 0.3.6 && < 0.4, - hashable >= 1.2.7 && < 1.3, + hashable >= 1.3.0 && < 1.4, hashtables >= 1.2.3 && < 1.3, - template-haskell >= 2.14.0 && < 2.15, + template-haskell >= 2.14.0 && < 2.16, unordered-containers >= 0.2.10 && < 0.3, exceptions >= 0.10.1 && < 0.11, mtl >= 2.2.2 && < 2.3, lens >= 4.17 && < 4.18, linear >= 1.20.8 && < 1.21, - sdl2 >= 2.4.1 && < 2.5, + sdl2 >= 2.5.0 && < 2.6, sdl2-gfx >= 0.2 && < 0.3, sdl2-image >= 2.0.0 && < 2.1, sdl2-ttf >= 2.1.0 && < 2.2, transformers >= 0.5.6 && < 0.6, - trifecta >= 2 && < 2.1, + trifecta >= 2.1 && < 2.2, uuid >= 1.3.12 && < 1.4, yaml >= 0.11.0 && < 0.12, mwc-random >= 0.14.0 && < 0.15, diff --git a/src/Control/Monad/Caster.hs b/src/Control/Monad/Caster.hs --- a/src/Control/Monad/Caster.hs +++ b/src/Control/Monad/Caster.hs @@ -5,10 +5,12 @@ LogLevel (..), LogQueue, stdoutLogger, + iohandleLogger, ) where import Control.Monad.IO.Class import Control.Concurrent +import GHC.IO.Handle (Handle) import System.Log.Caster as Caster class MonadLogger m where @@ -33,5 +35,16 @@ _ <- forkIO $ relayLog chan level terminalListener _ <- forkIO $ broadcastLog q chan + + return q + +iohandleLogger :: Handle -> LogLevel -> IO LogQueue +iohandleLogger handle level = do + chan <- newLogChan + q <- newLogQueue + + _ <- forkIO + $ relayLog chan level (handleListenerFlush terminalFormatter handle) + _ <- forkIO $ broadcastLog q chan return q diff --git a/src/Data/Component/Basic.hs b/src/Data/Component/Basic.hs --- a/src/Data/Component/Basic.hs +++ b/src/Data/Component/Basic.hs @@ -10,8 +10,11 @@ -} module Data.Component.Basic where +import Control.Lens hiding (contains) +import Control.Monad import Data.Aeson import Data.Aeson.Types +import qualified Data.HashMap.Strict as HM import Data.Typeable import qualified SDL import qualified SDL.Vect as Vect @@ -20,9 +23,15 @@ -- | Basic config type data Config = Config { size :: Vect.V2 Int, - position :: Vect.V2 Int -} + position :: Vect.V2 Int, + visible :: Bool +} deriving (Show) +makeClassy_ ''Config + +defConfig :: Config +defConfig = Config {size = 0, position = 0, visible = True} + instance FromJSON Config where parseJSON = withObject "config" $ \v -> do sizeMaybe <- v .:? "size" @@ -33,8 +42,11 @@ position <- (\w -> maybe (return 0) w positionMaybe) $ withObject "position" $ \v -> Vect.V2 <$> v .: "x" <*> v .: "y" - return $ Config size position + visibleMaybe <- v .:? "visible" + let visible = maybe True id visibleMaybe + return $ Config size position visible + -- | This wrapper function is useful when you write your component config parser. wrapConfig :: (Config -> a -> Parser r) -> (Object -> Parser a) -> Value -> Parser r @@ -58,16 +70,22 @@ MouseOver :: Vect.V2 Int -- ^ The relative position of the mouse pointer -> Signal + SetVisibility :: Bool -> Signal deriving Typeable instance EventType Signal where getEventType (MousePressed _) = "mouse-pressed" getEventType (MouseReleased _) = "mouse-released" getEventType (MouseOver _) = "mouse-over" + getEventType (SetVisibility _) = "set-visibility" + getEventProperties (SetVisibility o) = HM.fromList [("visibility", Bool o)] + getEventProperties _ = error "not implemeneted yet" + -- | This automatically applies basic configuration such as: position. wrapFigures :: Config -> [Figure] -> [Figure] -wrapFigures conf = map (translate (position conf)) +wrapFigures conf fs = + if not (conf ^. _visible) then [] else map (translate (position conf)) fs -- | This wrapper function is useful when you write your own 'onSignal' component. wrapSignal @@ -77,14 +95,16 @@ , MonadIO m , ComponentUnit c ) - => (c -> Config) -- ^ 'Config' getter - -> (Event -> c -> LightT env m c) -- ^ Custom @onSignal@ function + => Lens' c Config -- ^ lens to 'Config' + -> (Event -> c -> LightT env m c) -- ^ custom @onSignal@ function -> (Event -> c -> LightT env m c) -wrapSignal getter f ev comp = do - emitBasicSignal ev (getter comp) - f ev comp +wrapSignal lens f ev comp = do + conf' <- handleBasicSignal ev (comp ^. lens) --- | Basic signaling function. + when (comp ^. lens ^. _visible) $ emitBasicSignal ev conf' + f ev (comp & lens .~ conf') + +-- | Basic signaling function. Signals are emitted towards the source component. emitBasicSignal :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m) => Event @@ -92,17 +112,29 @@ -> LightT env m () emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ _ (SDL.P pos) _)))) conf | contains (areaRectangle conf) (fmap fromEnum pos) - = emit $ MouseOver $ fmap fromEnum pos - position conf + = view _uid + >>= \t -> emit (Just t) $ MouseOver $ fmap fromEnum pos - position conf emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ state _ _ _ (SDL.P pos))))) conf | contains (areaRectangle conf) (fmap fromEnum pos) - = emit - $ ( case state of - SDL.Pressed -> MousePressed - SDL.Released -> MouseReleased - ) - $ fmap fromEnum pos - - position conf + = view _uid >>= \t -> + emit (Just t) + $ ( case state of + SDL.Pressed -> MousePressed + SDL.Released -> MouseReleased + ) + $ fmap fromEnum pos + - position conf emitBasicSignal _ _ = return () + +-- | handle basic signals +handleBasicSignal + :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m) + => Event + -> Config + -> LightT env m Config +handleBasicSignal ev conf = case asSignal ev of + Just (SetVisibility b) -> return $ conf { visible = b } + _ -> return conf contains :: (Ord a, Num a) => SDL.Rectangle a -> Vect.V2 a -> Bool contains (SDL.Rectangle (Vect.P (Vect.V2 x y)) (Vect.V2 w h)) (Vect.V2 px py) = diff --git a/src/Data/Component/Button.hs b/src/Data/Component/Button.hs --- a/src/Data/Component/Button.hs +++ b/src/Data/Component/Button.hs @@ -35,7 +35,7 @@ useCache _ _ = True onSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ _ _ _)))) comp = do - emit Click + emitGlobally Click return comp onSignal _ comp = return comp diff --git a/src/Data/Component/Layer.hs b/src/Data/Component/Layer.hs --- a/src/Data/Component/Layer.hs +++ b/src/Data/Component/Layer.hs @@ -1,6 +1,7 @@ module Data.Component.Layer where import Control.Lens +import Control.Lens.TH.Rules import Control.Monad import Data.Aeson import Linear @@ -9,27 +10,33 @@ import qualified SDL.Vect as Vect import qualified Data.Component.Basic as Basic +data Config = Config { + basic :: Basic.Config, + image :: FilePath +} + +instance FromJSON Config where + parseJSON = Basic.wrapConfig (\b l -> return $ Config b l) $ \v -> + v .: "image" + data Layer = Layer { layer :: Figure, config :: Config } +makeLensesWith lensRules_ ''Config +makeLensesWith lensRules_ ''Layer + +instance Basic.HasConfig Config where + config = _basic + instance ComponentUnit Layer where figures comp = return $ Basic.wrapFigures (basic $ config comp) [layer comp] - onSignal = Basic.wrapSignal (basic . config) (\_ -> return) + onSignal = Basic.wrapSignal (_config . Basic.config) (\_ -> return) useCache _ _ = True -data Config = Config { - basic :: Basic.Config, - image :: FilePath -} - -instance FromJSON Config where - parseJSON = Basic.wrapConfig (\b l -> return $ Config b l) $ \v -> - v .: "image" - new :: Config -> MiniLight Layer new conf = do pic <- picture (image conf) @@ -41,45 +48,51 @@ newNineTile :: Config -> MiniLight Layer newNineTile conf = do - pic <- picture $ image conf - let siz = fmap toEnum $ Basic.size $ basic conf - let tex = texture pic - let texSize = fmap toEnum $ getFigureSize pic + mrenderer <- view _renderer + target <- flip mapM mrenderer $ \renderer -> do + pic <- picture $ image conf + let siz = fmap toEnum $ Basic.size $ basic conf + let Just tex = texture pic + let texSize = fmap toEnum $ getFigureSize pic - tinfo <- SDL.queryTexture tex - renderer <- view _renderer + tinfo <- SDL.queryTexture tex - target <- SDL.createTexture renderer + target <- SDL.createTexture renderer (SDL.texturePixelFormat tinfo) SDL.TextureAccessTarget siz - SDL.rendererRenderTarget renderer SDL.$= Just target - SDL.textureBlendMode target SDL.$= SDL.BlendAlphaBlend + SDL.rendererRenderTarget renderer SDL.$= Just target + SDL.textureBlendMode target SDL.$= SDL.BlendAlphaBlend - let tileSize = fmap (`div` 3) texSize + let tileSize = fmap (`div` 3) texSize - forM_ [0 .. 2] $ \ix -> forM_ [0 .. 2] $ \iy -> do - let targetSize = V2 - (if ix == 1 then siz ^. _x - 2 * tileSize ^. _x else tileSize ^. _x) - (if iy == 1 then siz ^. _y - 2 * tileSize ^. _y else tileSize ^. _y) - let targetLoc = V2 - ( if ix == 0 - then 0 - else if ix == 1 then tileSize ^. _x else siz ^. _x - tileSize ^. _x - ) - ( if iy == 0 - then 0 - else if iy == 1 then tileSize ^. _y else siz ^. _y - tileSize ^. _y - ) + forM_ [0 .. 2] $ \ix -> forM_ [0 .. 2] $ \iy -> do + let targetSize = V2 + (if ix == 1 then siz ^. _x - 2 * tileSize ^. _x else tileSize ^. _x) + (if iy == 1 then siz ^. _y - 2 * tileSize ^. _y else tileSize ^. _y) + let targetLoc = V2 + ( if ix == 0 + then 0 + else if ix == 1 + then tileSize ^. _x + else siz ^. _x - tileSize ^. _x + ) + ( if iy == 0 + then 0 + else if iy == 1 + then tileSize ^. _y + else siz ^. _y - tileSize ^. _y + ) - SDL.copy - renderer - tex - (Just $ SDL.Rectangle (SDL.P (tileSize * Vect.V2 ix iy)) tileSize) - (Just $ SDL.Rectangle (SDL.P targetLoc) targetSize) + SDL.copy + renderer + tex + (Just $ SDL.Rectangle (SDL.P (tileSize * Vect.V2 ix iy)) tileSize) + (Just $ SDL.Rectangle (SDL.P targetLoc) targetSize) - SDL.rendererRenderTarget renderer SDL.$= Nothing + SDL.rendererRenderTarget renderer SDL.$= Nothing - tex <- fromTexture target - return $ Layer {layer = tex, config = conf} + return target + tex <- maybe (return emptyFigure) fromTexture target + return $ Layer {layer = tex, config = conf} diff --git a/src/Data/Component/MessageEngine.hs b/src/Data/Component/MessageEngine.hs --- a/src/Data/Component/MessageEngine.hs +++ b/src/Data/Component/MessageEngine.hs @@ -38,16 +38,22 @@ textCounter :: Int, textTexture :: Figure, finished :: Bool, + currentMessages :: V.Vector T.Text, config :: Config } makeLensesWith lensRules_ ''MessageEngine -data EngineEvent = NextPage +data EngineEvent where + NextPage :: EngineEvent + SetMessage + :: [T.Text] -- ^ pages messages + -> EngineEvent deriving Typeable instance EventType EngineEvent where getEventType NextPage = "next-page" + getEventType (SetMessage _) = "set-message" instance ComponentUnit MessageEngine where update = execStateT $ do @@ -59,14 +65,15 @@ tc <- use _textCounter p <- use _page - messages <- use $ _config . _messages + messages <- use _currentMessages when (p == V.length messages - 1 && tc == T.length (messages V.! p)) $ do _finished .= True _counter %= (+1) figures comp = do - (w, h) <- SDL.Font.size (comp ^. _fontData) (T.take (comp ^. _textCounter) $ (config comp ^. _messages) V.! (comp ^. _page)) + let messages = comp ^. _currentMessages + (w, h) <- SDL.Font.size (comp ^. _fontData) (T.take (comp ^. _textCounter) $ messages V.! (comp ^. _page)) return [ clip (SDL.Rectangle 0 (Vect.V2 w h)) $ textTexture comp @@ -74,36 +81,49 @@ useCache c1 c2 = page c1 == page c2 && textCounter c1 == textCounter c2 - onSignal ev c = view _uid >>= \u -> go (ev,u) c - where - go (uncurry asSignal -> Just NextPage) = execStateT $ do - fin <- use _finished - unless fin $ do - _page %= (+1) - _textCounter .= 0 + onSignal ev = execStateT $ case asSignal ev of + Just NextPage -> do + fin <- use _finished + unless fin $ do + _page %= (+1) + _textCounter .= 0 - font <- use _fontData - fontColor <- use $ _config . _font . Font._color - p <- use _page - messages <- use $ _config . _messages - tex <- lift $ liftMiniLight $ text font fontColor (messages V.! p) - _textTexture .= tex + font <- use _fontData + fontColor <- use $ _config . _font . Font._color + p <- use _page + messages <- use _currentMessages + tex <- lift $ liftMiniLight $ text font fontColor (messages V.! p) + _textTexture .= tex + Just (SetMessage ms) -> do + let vs = V.fromList ms + _counter .= 0 + _page .= 0 - go _ = return + st <- use $ _config . _static + _textCounter .= if st then T.length (vs V.! 0) else 0 + font <- use _fontData + fontColor <- use $ _config . _font . Font._color + tex <- lift $ liftMiniLight $ text font fontColor $ vs V.! 0 + _textTexture .= tex + _finished .= st + _currentMessages .= vs + _ -> return () + new :: Config -> MiniLight MessageEngine new conf = do font <- Font.loadFontFrom (font conf) textTexture <- text font (conf ^. _font ^. Font._color) $ messages conf V.! 0 return $ MessageEngine - { fontData = font - , counter = 0 - , page = 0 + { fontData = font + , counter = 0 + , page = 0 , textCounter = if static conf then T.length (messages conf V.! 0) else 0 - , textTexture = textTexture - , finished = static conf - , config = conf + , textTexture = textTexture + , finished = static conf + , currentMessages = messages conf + , config = conf } wrapSignal diff --git a/src/Data/Component/MessageLayer.hs b/src/Data/Component/MessageLayer.hs --- a/src/Data/Component/MessageLayer.hs +++ b/src/Data/Component/MessageLayer.hs @@ -4,6 +4,7 @@ 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 @@ -13,6 +14,7 @@ import qualified SDL.Vect as Vect data Config = Config { + basic :: Basic.Config, engine :: CME.Config, window :: CLayer.Config, next :: CAnim.Config @@ -24,7 +26,7 @@ nextConf <- parseJSON =<< v .: "next" messageEngineConf <- parseJSON =<< v .: "engine" - return $ Config messageEngineConf layerConf nextConf + return $ Config (layerConf ^. Basic.config) messageEngineConf layerConf nextConf data MessageLayer = MessageLayer { messageEngine :: CME.MessageEngine, @@ -33,14 +35,25 @@ config :: Config } +makeLensesWith lensRules_ ''Config makeLensesWith lensRules_ ''MessageLayer +instance Basic.HasConfig Config where + config = _basic + engineL :: Lens' MessageLayer CME.MessageEngine engineL = lens messageEngine (\s a -> s { messageEngine = a }) cursorL :: Lens' MessageLayer CAnim.AnimationLayer cursorL = lens cursor (\s a -> s { cursor = a }) +data MessageLayerEvent where + Finish :: MessageLayerEvent + deriving Typeable + +instance EventType MessageLayerEvent where + getEventType Finish = "finish" + instance ComponentUnit MessageLayer where update = execStateT $ do zoom engineL $ do @@ -66,14 +79,16 @@ ++ map (translate (position + Vect.V2 ((windowSize ^. _x - cursorSize ^. _x) `div` 2) (windowSize ^. _y - cursorSize ^. _y))) cursorLayer onSignal - = Basic.wrapSignal (CLayer.basic . CLayer.config . layer) + = Basic.wrapSignal (_config . Basic.config) $ CME.wrapSignal _messageEngine - $ \ev c -> view _uid >>= \u -> go (ev,u) c - where - go (uncurry asSignal -> Just (Basic.MouseReleased _)) = execStateT $ do - lift $ emit CME.NextPage + $ \ev -> execStateT $ case asSignal ev of + Just (Basic.MouseReleased _) -> do + me <- use _messageEngine - go _ = return + if me ^. CME._finished + then lift $ emitGlobally Finish + else lift $ emitGlobally CME.NextPage + _ -> return () new :: Config -> MiniLight MessageLayer new conf = do diff --git a/src/Data/Component/Resolver.hs b/src/Data/Component/Resolver.hs --- a/src/Data/Component/Resolver.hs +++ b/src/Data/Component/Resolver.hs @@ -2,7 +2,7 @@ -} module Data.Component.Resolver ( resolver, - foldResult, + extendResolver, ) where import Control.Monad @@ -42,3 +42,13 @@ resultM (fromJSON props) $ newComponent uid <=< Layer.newNineTile "selection" -> resultM (fromJSON props) $ newComponent uid <=< Selection.new _ -> return $ Left $ "Unsupported component: " ++ T.unpack name + +extendResolver + :: (FromJSON a, ComponentUnit c) + => T.Text -- ^ Name + -> (a -> MiniLight c) -- ^ Constructor of the component + -> Resolver -- ^ Old resolver + -> Resolver +extendResolver newName func resolver name uid props = if name == newName + then resultM (fromJSON props) $ newComponent uid <=< func + else resolver name uid props diff --git a/src/Data/Component/Selection.hs b/src/Data/Component/Selection.hs --- a/src/Data/Component/Selection.hs +++ b/src/Data/Component/Selection.hs @@ -1,6 +1,7 @@ module Data.Component.Selection where import Control.Lens +import Control.Lens.TH.Rules import Control.Monad.State import Data.Aeson hiding ((.=)) import qualified Data.Config.Font as Font @@ -15,70 +16,92 @@ import qualified Data.Component.Basic as Basic import qualified Data.Component.Layer as Layer +data Config = Config { + basic :: Basic.Config, + labels :: V.Vector T.Text, + fontConfig :: Font.Config, + image :: FilePath +} + +instance FromJSON Config where + parseJSON = withObject "selection" $ \v -> + Config + <$> parseJSON (Object v) + <*> v .:? "labels" .!= V.empty + <*> (parseJSON =<< (v .: "font")) + <*> v .: "image" + data Selection = Selection { layer :: Layer.Layer, font :: SDL.Font.Font, hover :: Maybe Int, - conf :: Config + config :: Config, + currentLabels :: V.Vector T.Text } -hoverL :: Lens' Selection (Maybe Int) -hoverL = lens hover (\env r -> env { hover = r }) +makeLensesWith lensRules_ ''Config +makeLensesWith lensRules_ ''Selection +instance Basic.HasConfig Config where + config = _basic + instance ComponentUnit Selection where update = return figures comp = do let p = Vect.V2 15 10 - textTextures <- V.forM (V.indexed $ labels $ conf comp) $ \(i,label) -> liftMiniLight $ fmap (translate (p + Vect.V2 0 (i * 30))) $ text (font comp) (Font.color $ fontConfig $ conf comp) label + textTextures <- V.forM (V.indexed $ comp ^. _currentLabels) $ \(i,label) -> liftMiniLight $ fmap (translate (p + Vect.V2 0 (i * 30))) $ text (font comp) (Font.color $ fontConfig $ comp ^. _config) label base <- figures (layer comp) - highlight <- liftMiniLight $ rectangleFilled (Vect.V4 240 240 240 40) $ _y .~ 30 $ Basic.size (basic (conf comp)) + highlight <- liftMiniLight $ rectangleFilled (Vect.V4 240 240 240 40) $ _y .~ 30 $ comp ^. _config . Basic._size - return $ base - ++ map (translate (Basic.position $ basic $ conf comp)) (translate (Vect.V2 0 (maybe 0 id (hover comp) * 30 + p ^. _y)) highlight + return $ Basic.wrapFigures (comp ^. _config . Basic.config) $ base + ++ (translate (Vect.V2 0 (maybe 0 id (hover comp) * 30 + p ^. _y)) highlight : V.toList textTextures) - useCache c1 c2 = hover c1 == hover c2 + useCache c1 c2 + = c1 ^. _currentLabels == c2 ^. _currentLabels + && c1 ^. _config . Basic._visible == c2 ^. _config . Basic._visible && c1 ^. _hover == c2 ^. _hover - onSignal = Basic.wrapSignal (basic . conf) $ \ev sel -> flip execStateT sel $ do - uid <- view _uid + onSignal = Basic.wrapSignal (_config . Basic.config) $ \ev -> execStateT $ do + labels <- use _currentLabels - case ev `asSignal` uid of - Just (Basic.MouseOver pos) | (pos ^. _y) `div` 30 <= V.length (labels (conf sel)) - 1 -> do - hoverL .= Just ((pos ^. _y) `div` 30) - Just (Basic.MouseReleased pos) | (pos ^. _y) `div` 30 <= V.length (labels (conf sel)) - 1 -> do - lift $ emit $ Select ((pos ^. _y) `div` 30) + case asSignal ev of + Just (Basic.MouseOver pos) | (pos ^. _y) `div` 30 <= V.length labels - 1 -> do + _hover .= Just ((pos ^. _y) `div` 30) + Just (Basic.MouseReleased pos) | (pos ^. _y) `div` 30 <= V.length labels - 1 -> do + lift $ emitGlobally $ Select ((pos ^. _y) `div` 30) _ -> return () + case asSignal ev of + Just (SetOptions xs) -> _currentLabels .= V.fromList xs + _ -> return () + -- OMG + beforeClearCache _ [] = return () beforeClearCache _ figs = mapM_ freeFigure $ tail figs -data Config = Config { - basic :: Basic.Config, - labels :: V.Vector T.Text, - fontConfig :: Font.Config, - image :: FilePath -} - -instance FromJSON Config where - parseJSON = withObject "selection" $ \v -> - Config - <$> parseJSON (Object v) - <*> v .:? "labels" .!= V.empty - <*> (parseJSON =<< (v .: "font")) - <*> v .: "image" - data SelectionEvent = Select Int + | SetOptions [T.Text] deriving (Typeable) instance EventType SelectionEvent where getEventType (Select _) = "select" + getEventType (SetOptions _) = "set-options" getEventProperties (Select n) = HM.fromList [("index", Number $ fromIntegral n)] + getEventProperties (SetOptions ts) = HM.fromList [("options", Array $ fmap String $ V.fromList ts)] new :: Config -> MiniLight Selection new conf = do font <- Font.loadFontFrom (fontConfig conf) - layer <- Layer.newNineTile $ Layer.Config (basic conf) (image conf) - return $ Selection {font = font, conf = conf, hover = Nothing, layer = layer} + layer <- Layer.newNineTile $ Layer.Config + (Basic.defConfig { Basic.size = Basic.size $ basic conf }) + (image conf) + return $ Selection + { font = font + , config = conf + , hover = Nothing + , layer = layer + , currentLabels = conf ^. _labels + } diff --git a/src/Data/Config/Font.hs b/src/Data/Config/Font.hs --- a/src/Data/Config/Font.hs +++ b/src/Data/Config/Font.hs @@ -2,6 +2,7 @@ import Control.Lens import Data.Aeson +import qualified Data.Text as T import Data.Word (Word8) import MiniLight import qualified SDL.Font @@ -28,3 +29,10 @@ -- | Load a system font from 'Config' type. loadFontFrom :: Config -> MiniLight SDL.Font.Font loadFontFrom conf = loadFont (descriptor conf) (size conf) + +-- | Create a text texture from the config. +-- **NB** This function is a slow operation since it loads the font data every time. +textFrom :: Config -> T.Text -> MiniLight Figure +textFrom conf t = do + font <- loadFontFrom conf + text font (conf ^. _color) t diff --git a/src/MiniLight.hs b/src/MiniLight.hs --- a/src/MiniLight.hs +++ b/src/MiniLight.hs @@ -9,12 +9,18 @@ module MiniLight.Loader, runLightT, + runLightTWith, + LightConfig (..), + defLightConfig, LoopState (..), LoopConfig (..), defConfig, runMainloop, MiniLoop, runMiniloop, + runComponentEnv, + (@@!), + quit, ) where import Control.Concurrent (threadDelay, forkIO) @@ -23,12 +29,13 @@ import qualified Control.Monad.Caster as Caster import Control.Monad.Catch import Control.Monad.Reader -import Data.Foldable (foldlM) +import Data.Foldable import Data.Hashable (Hashable(..)) import qualified Data.HashMap.Strict as HM import Data.Maybe import Data.IORef import qualified Data.Registry as R +import qualified Data.Text as T import qualified Data.Vector as V import Graphics.Text.TrueType import MiniLight.Component @@ -43,19 +50,47 @@ instance Hashable SDL.Scancode where hashWithSalt n sc = hashWithSalt n (SDL.unwrapScancode sc) --- | Run a Light monad. +-- | Run a light monad with default configuration. +-- @ +-- runLightT = runLightTWith defLightConfig +-- @ runLightT :: (MonadIO m, MonadMask m) => LightT LightEnv m a -> m a -runLightT prog = withSDL $ withWindow $ \window -> do - renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer - fc <- loadFontCache - logger <- liftIO $ Caster.stdoutLogger Caster.LogDebug - runReaderT (runLightT' prog) - $ LightEnv {renderer = renderer, fontCache = fc, logger = logger} +runLightT = runLightTWith defLightConfig + +-- | Custom configuration for LightT +data LightConfig = LightConfig { + headless :: Bool, -- Set False if you don't need graphical user interface (mostly for testing) + logQueue :: Caster.LogLevel -> IO Caster.LogQueue, -- ^ LogQueue for logger + logLevel :: Caster.LogLevel -- ^ LogLevel for logger +} + +-- | Default configuration for 'runLightT' +defLightConfig :: LightConfig +defLightConfig = LightConfig + { headless = False + , logQueue = Caster.stdoutLogger + , logLevel = Caster.LogWarn + } + +-- | Run a Light monad. +runLightTWith + :: (MonadIO m, MonadMask m) => LightConfig -> LightT LightEnv m a -> m a +runLightTWith conf prog = + withSDLFont + $ ( if headless conf + then (\f -> f Nothing) + else withSDL . withWindow . (\f w -> f (Just w)) + ) + $ \mwindow -> do + renderer <- flip mapM mwindow $ \window -> do + SDL.createRenderer window (-1) SDL.defaultRenderer + fc <- loadFontCache + logger <- liftIO $ logQueue conf (logLevel conf) + runReaderT (runLightT' prog) + $ LightEnv {renderer = renderer, fontCache = fc, logger = logger} where - withSDL = - bracket (SDL.initializeAll >> SDL.Font.initialize) - (\_ -> SDL.Font.quit >> SDL.quit) - . const + withSDL = bracket SDL.initializeAll (\_ -> SDL.quit) . const + withSDLFont = bracket SDL.Font.initialize (\_ -> SDL.Font.quit) . const withWindow = bracket (SDL.createWindow "window" SDL.defaultWindow) SDL.destroyWindow @@ -122,6 +157,39 @@ instance HasComponentEnv (ComponentState env) where componentEnv = _componentEnvL +-- | Run an action over a component. +runComponentEnv + :: (HasLightEnv env, HasLoopEnv env) + => Component + -> ( forall env' + . (HasComponentEnv env', HasLoopEnv env', HasLightEnv env') + => LightT env' m () + ) + -> LightT env m () +runComponentEnv c = + envLightT (\env -> ComponentState env (ComponentEnv (getUID c) (getHooks c))) + + +-- | Emit a signal with a loader-defined target name +-- @ +-- (@@!) :: EventType et => T.Text -> et -> MiniLoop () +-- @ +(@@!) + :: ( EventType et + , HasLoaderEnv env + , HasLoopEnv env + , HasLightEnv env + , MonadIO m + ) + => T.Text + -> et + -> LightT env m () +t @@! ev = do + key <- fmap (\(Just x) -> x) $ lookupByTagID t + reg <- view _registry + v <- reg R.! key + runComponentEnv v $ emit (Just key) $ ev + -- | Same as 'runMainloop' but fixing the type. runMiniloop :: LoopConfig -> s -> (s -> MiniLoop s) -> MiniLight () runMiniloop = runMainloop LoopState @@ -147,11 +215,12 @@ events <- liftIO $ newMVar [] signalQueue <- liftIO $ newIORef [] reg <- R.new + tag <- liftIO $ newIORef $ HM.empty conf <- liftIO $ newIORef $ AppConfig V.empty V.empty run (LoopEnv {keyStates = HM.empty, events = events, signalQueue = signalQueue}) - (LoaderEnv {registry = reg, appConfig = conf}) + (LoaderEnv {registry = reg, tagRegistry = tag, appConfig = conf}) initial where run loop loader s = do @@ -175,9 +244,10 @@ R.register reg (getUID component) component go loop loader s = do - renderer <- view _renderer - liftIO $ SDL.rendererDrawColor renderer SDL.$= 255 - liftIO $ SDL.clear renderer + mrenderer <- view _renderer + forM_ mrenderer $ \renderer -> do + liftIO $ SDL.rendererDrawColor renderer SDL.$= 255 + liftIO $ SDL.clear renderer R.forV_ (loader ^. _registry) $ \comp -> draw comp @@ -192,18 +262,28 @@ ) $ update comp - s' <- envLightT (\env -> conv env loop loader) $ userloop s - - liftIO $ SDL.present renderer - - liftIO $ threadDelay (100000 `div` 60) - events <- SDL.pollEvents - keys <- SDL.getKeyboardState + s' <- envLightT (\env -> conv env loop loader) $ userloop s - envLightT (\env -> conv env loop loader) $ do + -- event handling + globalEvents <- envLightT (\env -> conv env loop loader) $ do evref <- view _events events <- liftIO $ modifyMVar evref (\a -> return ([], a)) + let (componentEvent, globalEvent, notifyEvent) = foldl' + ( \(a, b, c) -> \case + NotifyEvent n -> (a, b, n : c) + ev@(Signal _ (Just t) _) -> ((t, ev) : a, b, c) + ev -> (a, ev : b, c) + ) + ([], [], []) + events + -- send an event to the target + forM_ componentEvent $ \(target, ev) -> do + R.update (loader ^. _registry) target $ \v -> envLightT + (\env -> ComponentState env (ComponentEnv (getUID v) (getHooks v))) + (onSignal ev v) + + -- send a global event to all components R.modifyV_ (loader ^. _registry) $ \comp -> do foldlM ( \comp ev -> @@ -215,20 +295,22 @@ $ onSignal ev comp ) comp - events + globalEvent - forM_ - ( catMaybes $ map - ( \e -> case e of - NotifyEvent ev -> Just ev - _ -> Nothing - ) - events - ) - $ \ev -> patchAppConfig - (fromJust $ appConfigFile conf) - (componentResolver conf) + -- process notification events + forM_ notifyEvent + $ \ev -> patchAppConfig (fromJust $ appConfigFile conf) + (componentResolver conf) + return globalEvent + + forM_ mrenderer $ \renderer -> do + liftIO $ SDL.present renderer + + liftIO $ threadDelay (100000 `div` 60) + events <- SDL.pollEvents + keys <- SDL.getKeyboardState + envLightT (\env -> conv env loop loader) $ do evref <- view _events sigref <- view _signalQueue @@ -253,11 +335,17 @@ (watchKeys conf) let quit = any - ( \event -> case SDL.eventPayload event of - SDL.WindowClosedEvent _ -> True - SDL.QuitEvent -> True - _ -> False + ( \case + RawEvent (SDL.Event _ (SDL.WindowClosedEvent _)) -> True + RawEvent (SDL.Event _ SDL.QuitEvent ) -> True + _ -> False ) - events + globalEvents unless quit $ go loop' loader s' + +-- | Quit the mainloop and terminate the application. +quit :: (MonadIO m, HasLoopEnv env) => LightT env m () +quit = do + evref <- view _events + liftIO $ modifyMVar_ evref $ return . (RawEvent (SDL.Event 0 SDL.QuitEvent) :) diff --git a/src/MiniLight/Component.hs b/src/MiniLight/Component.hs --- a/src/MiniLight/Component.hs +++ b/src/MiniLight/Component.hs @@ -3,9 +3,11 @@ HasComponentEnv(..), ComponentEnv(..), emit, + emitGlobally, ComponentUnit(..), Component, + _unsafeAs, newComponent, getComponentSize, getUID, @@ -25,6 +27,7 @@ import MiniLight.Event import MiniLight.Figure import qualified SDL +import Unsafe.Coerce type HookMap = HM.HashMap T.Text (T.Text, Object -> Value) @@ -39,19 +42,28 @@ -- | Emit a signal, which will be catched at the next frame. emit :: (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) - => et + => Maybe T.Text -- ^ target component ID + -> et -> LightT env m () -emit et = do +emit target et = do uid <- view _uid ref <- view _signalQueue - liftIO $ modifyIORef' ref $ (signal uid et :) + liftIO $ modifyIORef' ref $ (signal uid target et :) hs <- view _callbacks case HM.lookup (getEventType et) =<< hs of - Just (name, param) -> liftIO - $ modifyIORef' ref (GlobalSignal name (param $ getEventProperties et) :) + Just (name, param) -> liftIO $ modifyIORef' + ref + (signal uid Nothing (EventData name (param $ getEventProperties et)) :) Nothing -> return () +-- | Emit a signal globally. +emitGlobally + :: (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) + => et + -> LightT env m () +emitGlobally = emit Nothing + -- | CompoonentUnit typeclass provides a way to define a new component. -- Any 'ComponentUnit' instance can be embedded into 'Component' type. class ComponentUnit c where @@ -93,6 +105,12 @@ cache :: IORef [Figure], callbackObject :: Maybe HookMap } + +-- | Unsafe coercing the component +_unsafeAs :: (ComponentUnit c) => Lens' Component c +_unsafeAs = lens + (\(Component _ c _ _ _) -> unsafeCoerce c) + (\(Component a _ c d e) b -> Component a (unsafeCoerce b) c d e) -- | Create a new component. newComponent diff --git a/src/MiniLight/Event.hs b/src/MiniLight/Event.hs --- a/src/MiniLight/Event.hs +++ b/src/MiniLight/Event.hs @@ -6,8 +6,12 @@ module MiniLight.Event ( Event (..), EventType (..), + EventData (..), signal, asSignal, + asRawEvent, + asNotifyEvent, + asEventData, ) where import qualified SDL @@ -41,14 +45,44 @@ -- | Event type representation data Event - = Signal T.Text Dynamic - | GlobalSignal T.Text Value + = Signal T.Text (Maybe T.Text) Dynamic | RawEvent SDL.Event | NotifyEvent Notify.Event -signal :: EventType a => T.Text -> a -> Event -signal t v = Signal t (toDyn v) +-- | Create a signal event. +signal + :: EventType a + => T.Text -- ^ source component ID + -> Maybe T.Text -- ^ target component ID, leave Nothing if this is a global event + -> a + -> Event +signal s t v = Signal s t (toDyn v) -asSignal :: EventType a => Event -> T.Text -> Maybe a -asSignal (Signal t1 v) t2 | t1 == t2 = fromDynamic v -asSignal _ _ = Nothing +-- | Cast a signal event to some 'EventType'. +asSignal :: EventType a => Event -> Maybe a +asSignal (Signal _ _ v) = fromDynamic v +asSignal _ = Nothing + +-- | Cast an event to some 'SDL.Event' +asRawEvent :: Event -> Maybe SDL.Event +asRawEvent (RawEvent e) = Just e +asRawEvent _ = Nothing + +-- | Cast an event to some 'Notify.Event' +asNotifyEvent :: Event -> Maybe Notify.Event +asNotifyEvent (NotifyEvent e) = Just e +asNotifyEvent _ = Nothing + +-- | Canonical datatype of 'Event'. It consists of event name and event data itself. +-- This type is usually used for global events. +data EventData = EventData T.Text Value + deriving (Show, Typeable) + +instance EventType EventData where + getEventType (EventData t _) = t + getEventProperties (EventData _ o) = HM.singleton "data" o + +-- | Cast a signal event to 'EventData' +asEventData :: Event -> Maybe EventData +asEventData (Signal _ Nothing v) = fromDynamic v +asEventData _ = Nothing diff --git a/src/MiniLight/Figure.hs b/src/MiniLight/Figure.hs --- a/src/MiniLight/Figure.hs +++ b/src/MiniLight/Figure.hs @@ -8,6 +8,7 @@ import Control.Lens import Control.Monad.Catch import Control.Monad.IO.Class +import Data.Foldable import qualified Data.Text as T import Data.Word (Word8) import Linear (_x, _y) @@ -31,18 +32,22 @@ -- | Figure type carries a texture, sizing information and rotation information. data Figure = Figure { - texture :: SDL.Texture, + texture :: Maybe SDL.Texture, -- ^ Texture can be Nothing in headless mode sourceArea :: SDL.Rectangle Int, targetArea :: SDL.Rectangle Int, rotation :: Double } +-- | A figure which has no texture. You can render it but do nothing. +emptyFigure :: Figure +emptyFigure = Figure Nothing (SDL.Rectangle 0 0) (SDL.Rectangle 0 0) 0 + getFigureSize :: Figure -> Vect.V2 Int getFigureSize fig = (\(SDL.Rectangle _ size) -> size) $ targetArea fig {-# INLINE getFigureSize #-} freeFigure :: MonadIO m => Figure -> m () -freeFigure = SDL.destroyTexture . texture +freeFigure = maybe (return ()) SDL.destroyTexture . texture {-# INLINE freeFigure #-} union :: SDL.Rectangle Int -> SDL.Rectangle Int -> SDL.Rectangle Int @@ -54,15 +59,15 @@ -- | Render a figure. render :: (HasLightEnv env, MonadIO m, MonadMask m) => Figure -> LightT env m () render fig = do - renderer <- view _renderer - - SDL.copyEx renderer - (texture fig) - (Just (fmap toEnum $ sourceArea fig)) - (Just (fmap toEnum $ targetArea fig)) - (realToFrac (rotation fig) * 180 / pi) - Nothing - (Vect.V2 False False) + mrend <- view _renderer + forM_ mrend $ \rend -> do + SDL.copyEx rend + ((\(Just t) -> t) $ texture fig) + (Just (fmap toEnum $ sourceArea fig)) + (Just (fmap toEnum $ targetArea fig)) + (realToFrac (rotation fig) * 180 / pi) + Nothing + (Vect.V2 False False) {-# INLINE render #-} -- | Render figures. @@ -139,75 +144,84 @@ {-# INLINE rotate #-} text font color txt = do - renderer <- view _renderer + mrend <- view _renderer + tex <- flip mapM mrend $ \rend -> do + withBlendedText font txt color $ \surf -> do + texture <- SDL.createTextureFromSurface rend surf + tinfo <- SDL.queryTexture texture + let rect = fmap fromEnum $ SDL.Rectangle (SDL.P 0) (Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo)) - withBlendedText font txt color $ \surf -> do - texture <- SDL.createTextureFromSurface renderer surf - tinfo <- SDL.queryTexture texture - let rect = fmap fromEnum $ SDL.Rectangle (SDL.P 0) (Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo)) + return $ Figure (Just texture) rect rect 0 - return $ Figure texture rect rect 0 + return $ maybe emptyFigure id tex {-# INLINE text #-} picture filepath = do - renderer <- view _renderer - - texture <- SDL.Image.loadTexture renderer filepath - tinfo <- SDL.queryTexture texture - let rect = fmap fromEnum $ SDL.Rectangle (SDL.P 0) (Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo)) + mrend <- view _renderer + tex <- flip mapM mrend $ \rend -> do + texture <- SDL.Image.loadTexture rend filepath + tinfo <- SDL.queryTexture texture + let rect = fmap fromEnum $ SDL.Rectangle (SDL.P 0) (Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo)) - return $ Figure texture rect rect 0 + return $ Figure (Just texture) rect rect 0 + return $ maybe emptyFigure id tex {-# INLINE picture #-} fromTexture tex = do tinfo <- SDL.queryTexture tex let size = fmap fromEnum $ Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo) - return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0 + return $ Figure (Just tex) (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0 {-# INLINE fromTexture #-} rectangleOutline color size = do - rend <- view _renderer - tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size) - SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend + mrend <- view _renderer + tex <- flip mapM mrend $ \rend -> do + tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size) + SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend - bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do - SDL.rendererRenderTarget rend SDL.$= Just tex - SDL.rendererDrawColor rend SDL.$= color - SDL.drawRect rend (Just $ SDL.Rectangle 0 (fmap toEnum size)) + bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do + SDL.rendererRenderTarget rend SDL.$= Just tex + SDL.rendererDrawColor rend SDL.$= color + SDL.drawRect rend (Just $ SDL.Rectangle 0 (fmap toEnum size)) + return tex return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0 {-# INLINE rectangleOutline #-} rectangleFilled color size = do - rend <- view _renderer - tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size) - SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend + mrend <- view _renderer + tex <- flip mapM mrend $ \rend -> do + tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size) + SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend - bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do - SDL.rendererRenderTarget rend SDL.$= Just tex - SDL.rendererDrawColor rend SDL.$= color - SDL.fillRect rend (Just $ SDL.Rectangle 0 (fmap toEnum size)) + bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do + SDL.rendererRenderTarget rend SDL.$= Just tex + SDL.rendererDrawColor rend SDL.$= color + SDL.fillRect rend (Just $ SDL.Rectangle 0 (fmap toEnum size)) + return tex return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0 {-# INLINE rectangleFilled #-} triangleOutline color size = do - rend <- view _renderer - tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size) - SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend + mrend <- view _renderer + tex <- flip mapM mrend $ \rend -> do + tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size) + SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend - bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do - SDL.rendererRenderTarget rend SDL.$= Just tex - SDL.rendererDrawColor rend SDL.$= color + bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do + SDL.rendererRenderTarget rend SDL.$= Just tex + SDL.rendererDrawColor rend SDL.$= color - let size' = fmap toEnum size - Gfx.smoothTriangle - rend - (Vect.V2 (size' ^. _x `div` 2) 0) - (Vect.V2 (size' ^. _x - 1) (size' ^. _y - 1)) - (Vect.V2 0 (size' ^. _y - 1)) - color + let size' = fmap toEnum size + Gfx.smoothTriangle + rend + (Vect.V2 (size' ^. _x `div` 2) 0) + (Vect.V2 (size' ^. _x - 1) (size' ^. _y - 1)) + (Vect.V2 0 (size' ^. _y - 1)) + color + return tex return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0 {-# INLINE triangleOutline #-} diff --git a/src/MiniLight/Light.hs b/src/MiniLight/Light.hs --- a/src/MiniLight/Light.hs +++ b/src/MiniLight/Light.hs @@ -46,7 +46,7 @@ -- | The environment for LightT monad. data LightEnv = LightEnv - { renderer :: SDL.Renderer -- ^ Renderer for SDL2 + { renderer :: Maybe SDL.Renderer -- ^ Renderer for SDL2 , fontCache :: FontMap -- ^ System font information , logger :: Caster.LogQueue -- ^ Logger connected stdout } diff --git a/src/MiniLight/Loader.hs b/src/MiniLight/Loader.hs --- a/src/MiniLight/Loader.hs +++ b/src/MiniLight/Loader.hs @@ -41,6 +41,7 @@ module MiniLight.Loader ( module MiniLight.Loader.Internal.Types, createComponentBy, + lookupByTagID, LoaderEnv (..), HasLoaderEnv (..), @@ -64,6 +65,7 @@ import Data.Aeson.Patch import Data.Aeson.Pointer import Data.IORef +import qualified Data.HashMap.Strict as HM import qualified Data.Registry as R import qualified Data.Text as T import qualified Data.Vector as V @@ -73,15 +75,35 @@ import MiniLight.Loader.Internal.Types import MiniLight.Loader.Internal.Resolver (resolve, resolveWith, parseAppConfig, emptyContext, Context(..)) +-- | The environment for config loader +data LoaderEnv = LoaderEnv { + registry :: R.Registry Component, + tagRegistry :: IORef (HM.HashMap T.Text T.Text), + appConfig :: IORef AppConfig +} + +makeClassy_ ''LoaderEnv + -- | Create a component with given resolver. createComponentBy - :: Resolver + :: (HasLoaderEnv env, HasLightEnv env, MonadIO m) + => Resolver -> Maybe T.Text -> ComponentConfig - -> MiniLight (Either String Component) + -> LightT env m (Either String Component) createComponentBy resolver uid config = do uuid <- maybe newUID return uid - result <- resolver (name config) uuid (properties config) + result <- liftMiniLight + $ resolver (componentType config) uuid (properties config) + + -- register tag + case tagID config of + Just tag -> do + regRef <- view _tagRegistry + liftIO $ modifyIORef' regRef $ \reg -> HM.insert tag uuid reg + Caster.debug $ "TagID registered: " <> show tag <> " = " <> show uuid + _ -> return () + return $ fmap ( \c -> setHooks c @@ -95,13 +117,15 @@ ) result --- | The environment for config loader -data LoaderEnv = LoaderEnv { - registry :: R.Registry Component, - appConfig :: IORef AppConfig -} +lookupByTagID + :: (HasLightEnv env, HasLoaderEnv env, MonadIO m) + => T.Text + -> LightT env m (Maybe T.Text) +lookupByTagID tag = do + regRef <- view _tagRegistry + reg <- liftIO $ readIORef regRef -makeClassy_ ''LoaderEnv + return $ HM.lookup tag reg -- | Load an config file and return the resolved @AppConfig@. resolveConfig :: MonadIO m => FilePath -> m (Either T.Text AppConfig) @@ -127,7 +151,7 @@ confs <- lift $ fmap (V.mapMaybe id) $ V.forM (app conf) $ \conf -> do uid <- newUID - result <- liftMiniLight $ createComponentBy mapper (Just uid) conf + result <- createComponentBy mapper (Just uid) conf case result of Left e -> do @@ -138,8 +162,8 @@ R.register reg uid component Caster.info - $ "Component loaded: {name: " - <> show (name conf) + $ "Component loaded: {type: " + <> show (componentType conf) <> ", uid: " <> show uid <> "}" @@ -200,9 +224,7 @@ newID <- lift newUID component <- do - result <- lift $ liftMiniLight $ createComponentBy resolver - (Just newID) - compConf + result <- lift $ createComponentBy resolver (Just newID) compConf case result of Left err -> do @@ -215,8 +237,8 @@ lift $ Caster.info - $ "Component registered: {name: " - <> show (name compConf) + $ "Component registered: {type: " + <> show (componentType compConf) <> ", uid: " <> show (getUID component) <> "}" @@ -255,9 +277,7 @@ let uid = uuid appConf V.! n component <- do - result <- lift $ liftMiniLight $ createComponentBy resolver - (Just uid) - compConf + result <- lift $ createComponentBy resolver (Just uid) compConf case result of Left err -> do @@ -270,7 +290,7 @@ lift $ Caster.info $ "Component replaced: {name: " - <> show (name compConf) + <> show (componentType compConf) <> ", uid: " <> show (getUID component) <> "}" diff --git a/src/MiniLight/Loader/Internal/Resolver.hs b/src/MiniLight/Loader/Internal/Resolver.hs --- a/src/MiniLight/Loader/Internal/Resolver.hs +++ b/src/MiniLight/Loader/Internal/Resolver.hs @@ -201,7 +201,7 @@ app _ ast = Left $ "Invalid format: " <> T.pack (show ast) component :: Context -> Value -> Either T.Text ComponentConfig - component ctx (Object obj) | all (`HM.member` obj) ["name", "properties"] = do + component ctx (Object obj) | all (`HM.member` obj) ["type", "properties"] = do let ctx' = maybe ctx @@ -211,13 +211,16 @@ ) (HM.lookup "_vars" obj) - nameValue <- resolveWith ctx' (obj HM.! "name") + nameValue <- resolveWith ctx' (obj HM.! "type") case nameValue of String name -> do props <- resolveWith ctx' (obj HM.! "properties") hooks <- sequence $ (fmap (\(Object o) -> mapM toHook o) $ HM.lookup "hooks" obj) - Right $ ComponentConfig name props hooks + Right $ ComponentConfig name + (fmap (\(String s) -> s) $ HM.lookup "id" obj) + props + hooks _ -> Left $ "Invalid format: " <> T.pack (show nameValue) component _ ast = Left $ "Invalid format: " <> T.pack (show ast) diff --git a/src/MiniLight/Loader/Internal/Types.hs b/src/MiniLight/Loader/Internal/Types.hs --- a/src/MiniLight/Loader/Internal/Types.hs +++ b/src/MiniLight/Loader/Internal/Types.hs @@ -32,20 +32,22 @@ -- | A configuration for a component data ComponentConfig = ComponentConfig { - name :: T.Text, + componentType :: T.Text, + tagID :: Maybe T.Text, properties :: Value, hooks :: Maybe (HM.HashMap T.Text Hook) } instance ToJSON ComponentConfig where - toJSON v = toJSON $ HM.fromList [("name" :: String, String (name v)), ("properties", properties v)] + toJSON v = toJSON $ HM.fromList $ [("type" :: String, String (componentType v)), ("properties", properties v)] ++ maybe [] (\x -> [("id", String x)]) (tagID v) instance FromJSON ComponentConfig where parseJSON = withObject "component" $ \v -> do - name <- v .: "name" + componentType <- v .: "type" + tagID <- v .:? "id" props <- v .: "properties" - return $ ComponentConfig name props Nothing + return $ ComponentConfig componentType tagID props Nothing -- | A configuration for the application itself data AppConfig = AppConfig {