minilight 0.4.0 → 0.4.1

raw patch · 18 files changed

+574/−261 lines, 18 filesdep ~hashabledep ~sdl2dep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: hashable, sdl2, template-haskell, trifecta

API changes (from Hackage documentation)

Files

• minilight.cabal +5/−5
• src/Control/Monad/Caster.hs +13/−0
• src/Data/Component/Basic.hs +50/−18
• src/Data/Component/Button.hs +1/−1
• src/Data/Component/Layer.hs +54/−41
• src/Data/Component/MessageEngine.hs +43/−23
• src/Data/Component/MessageLayer.hs +22/−7
• src/Data/Component/Resolver.hs +11/−1
• src/Data/Component/Selection.hs +55/−32
• src/Data/Config/Font.hs +8/−0
• src/MiniLight.hs +129/−41
• src/MiniLight/Component.hs +23/−5
• src/MiniLight/Event.hs +41/−7
• src/MiniLight/Figure.hs +65/−51
• src/MiniLight/Light.hs +1/−1
• src/MiniLight/Loader.hs +41/−21
• src/MiniLight/Loader/Internal/Resolver.hs +6/−3
• src/MiniLight/Loader/Internal/Types.hs +6/−4

@@ -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,

@@ -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

@@ -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) =

@@ -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 

@@ -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}

@@ -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

@@ -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

@@ -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

@@ -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+    }

@@ -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

@@ -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) :)

@@ -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

@@ -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

@@ -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 #-}

@@ -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   }

@@ -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)       <> "}"

@@ -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)

@@ -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 {