minilight 0.3.0 → 0.4.0

raw patch · 22 files changed

+945/−657 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +1/−1
• minilight.cabal +6/−5
• src/Control/Lens/TH/Rules.hs +9/−0
• src/Data/Component/Basic.hs +4/−1
• src/Data/Component/Button.hs +2/−1
• src/Data/Component/Layer.hs +4/−0
• src/Data/Component/MessageEngine.hs +86/−37
• src/Data/Component/MessageLayer.hs +25/−12
• src/Data/Component/Selection.hs +15/−2
• src/Data/Config/Font.hs +9/−11
• src/Data/Vector/Mutable/PushBack.hs +1/−1
• src/MiniLight.hs +44/−25
• src/MiniLight/Component.hs +146/−36
• src/MiniLight/Component/Internal/Resolver.hs +0/−129
• src/MiniLight/Component/Internal/Types.hs +0/−50
• src/MiniLight/Component/Loader.hs +0/−217
• src/MiniLight/Component/Types.hs +0/−125
• src/MiniLight/Event.hs +13/−4
• src/MiniLight/Loader.hs +279/−0
• src/MiniLight/Loader/Internal/Resolver.hs +223/−0
• src/MiniLight/Loader/Internal/Types.hs +71/−0

@@ -1,5 +1,12 @@ # Revision history for minilight +## 0.4 -- 2019-06-01++* Features:+    * Hooks feature in Component Loader+    * Improve MessageEngine component+    * Improve Loader functions+ ## 0.3 -- 2019-05-05  * New features:

@@ -77,7 +77,7 @@           size: 22 ``` -For the configuration syntax, see [MiniLight.Component](https://hackage.haskell.org/package/minilight-0.2.0/docs/MiniLight-Component.html).+For the configuration syntax, see [MiniLight.Loader](https://hackage.haskell.org/package/minilight/docs/MiniLight-Loader.html).  For the pre-defined components, see the modules under `Data.Component`. 

@@ -3,7 +3,7 @@ --   For further documentation, see http://haskell.org/cabal/users-guide/  name:                minilight-version:             0.3.0+version:             0.4.0 synopsis:            A SDL2-based graphics library, batteries-included. description:   This package provides the wheel for a graphical application or a game.@@ -32,6 +32,7 @@  library   exposed-modules:+    Control.Lens.TH.Rules     Control.Monad.Caster     Data.Vector.Mutable.PushBack     Data.Registry@@ -42,10 +43,9 @@     MiniLight.Light     MiniLight.Event     MiniLight.Component-    MiniLight.Component.Types-    MiniLight.Component.Internal.Types-    MiniLight.Component.Internal.Resolver-    MiniLight.Component.Loader+    MiniLight.Loader.Internal.Types+    MiniLight.Loader.Internal.Resolver+    MiniLight.Loader     Data.Config.Font     Data.Component.Basic     Data.Component.Layer@@ -97,6 +97,7 @@     RankNTypes     Strict     TemplateHaskell+    ViewPatterns   ghc-options: -Wall -Wno-name-shadowing  test-suite tests

@@ -0,0 +1,9 @@+module Control.Lens.TH.Rules where++import Control.Lens+import Language.Haskell.TH++-- | Custom rules of the lens. All lens are prefixed by '_'.+lensRules_ :: LensRules+lensRules_ =+  lensRules & lensField .~ \_ _ n -> [TopName (mkName ('_' : nameBase n))]

@@ -60,7 +60,10 @@     -> Signal   deriving Typeable -instance EventType Signal+instance EventType Signal where+  getEventType (MousePressed _) = "mouse-pressed"+  getEventType (MouseReleased _) = "mouse-released"+  getEventType (MouseOver _) = "mouse-over"  -- | This automatically applies basic configuration such as: position. wrapFigures :: Config -> [Figure] -> [Figure]

@@ -17,7 +17,8 @@ data ButtonEvent = Click   deriving Typeable -instance EventType ButtonEvent+instance EventType ButtonEvent where+  getEventType Click = "click"  instance ComponentUnit Button where   update = return

@@ -17,6 +17,10 @@ instance ComponentUnit Layer where   figures comp = return $ Basic.wrapFigures (basic $ config comp) [layer comp] +  onSignal = Basic.wrapSignal (basic . config) (\_ -> return)++  useCache _ _ = True+ data Config = Config {   basic :: Basic.Config,   image :: FilePath

@@ -1,78 +1,127 @@ module Data.Component.MessageEngine where  import Control.Lens+import Control.Lens.TH.Rules import Control.Monad.State-import Data.Aeson+import Control.Monad.Catch (MonadMask)+import Data.Aeson hiding ((.=))+import qualified Data.Config.Font as Font import qualified Data.Text as T-import Data.Word (Word8)+import qualified Data.Vector as V+import Data.Typeable import MiniLight import qualified SDL import qualified SDL.Font import qualified SDL.Vect as Vect +-- | 'MessageEngine' configuration. If @static@ enabled, only the first page will be rendered.+data Config = Config {+  messages :: V.Vector T.Text,  -- ^ paged messages+  static :: Bool,+  font :: Font.Config+}++makeLensesWith lensRules_ ''Config++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    messages <- v .: "messages"+    static <- v .:? "static" .!= False+    font <- v .: "font"++    return $ Config messages static font+ data MessageEngine = MessageEngine {-  font :: SDL.Font.Font,+  fontData :: SDL.Font.Font,   counter :: Int,-  rendered :: Int,+  page :: Int,+  textCounter :: Int,   textTexture :: Figure,   finished :: Bool,   config :: Config } +makeLensesWith lensRules_ ''MessageEngine++data EngineEvent = NextPage+  deriving Typeable++instance EventType EngineEvent where+  getEventType NextPage = "next-page"+ instance ComponentUnit MessageEngine where   update = execStateT $ do-    comp <- get--    unless (finished comp) $ do-      when (counter comp `mod` 10 == 0) $ do-        id %= (\c -> c { rendered = rendered c + 1 })+    fin <- use _finished+    unless fin $ do+      cnt <- use _counter+      when (cnt `mod` 10 == 0) $ do+        _textCounter %= (+1) -        comp <- get-        when (rendered comp == T.length (messages (config comp))) $ do-          id %= (\c -> c { finished = True })+        tc <- use _textCounter+        p <- use _page+        messages <- use $ _config . _messages+        when (p == V.length messages - 1 && tc == T.length (messages V.! p)) $ do+          _finished .= True -      id %= (\c -> c { counter = counter c + 1 })+      _counter %= (+1)    figures comp = do-    (w, h) <- SDL.Font.size (font comp) (T.take (rendered comp) $ messages (config comp))+    (w, h) <- SDL.Font.size (comp ^. _fontData) (T.take (comp ^. _textCounter) $ (config comp ^. _messages) V.! (comp ^. _page))      return [       clip (SDL.Rectangle 0 (Vect.V2 w h)) $ textTexture comp       ] -data Config = Config {-  messages :: T.Text,-  static :: Bool,-  color :: Vect.V4 Word8,-  fontConf :: FontDescriptor,-  fontSize :: Int-}+  useCache c1 c2 = page c1 == page c2 && textCounter c1 == textCounter c2 -instance FromJSON Config where-  parseJSON = withObject "config" $ \v -> do-    messages <- v .: "messages"-    static <- v .:? "static" .!= False-    [r,g,b,a] <- v .:? "color" .!= [255, 255, 255, 255]-    (fontConf, size) <- (v .: "font" >>=) $ withObject "font" $ \v -> do-      family <- v .: "family"-      size <- v .: "size"-      bold <- v .:? "bold" .!= False-      italic <- v .:? "italic" .!= False+  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 -      return $ (FontDescriptor family (FontStyle bold italic), size)+          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 -    return $ Config messages static (Vect.V4 r g b a) fontConf size+      go _ = return  new :: Config -> MiniLight MessageEngine new conf = do-  font        <- loadFont (fontConf conf) (fontSize conf)-  textTexture <- text font (color conf) $ messages conf+  font        <- Font.loadFontFrom (font conf)+  textTexture <- text font (conf ^. _font ^. Font._color) $ messages conf V.! 0    return $ MessageEngine-    { font        = font+    { fontData    = font     , counter     = 0-    , rendered    = if static conf then T.length (messages conf) else 0+    , page        = 0+    , textCounter = if static conf then T.length (messages conf V.! 0) else 0     , textTexture = textTexture     , finished    = static conf     , config      = conf     }++wrapSignal+  :: ( HasLightEnv env+     , HasLoopEnv env+     , HasComponentEnv env+     , MonadIO m+     , MonadMask m+     )+  => (Lens' c MessageEngine)+  -> (Event -> c -> LightT env m c)+  -> (Event -> c -> LightT env m c)+wrapSignal lens f ev = execStateT $ do+  zoom lens $ do+    st  <- use id+    st' <- lift $ onSignal ev st+    id .= st'++  st  <- use id+  st' <- lift $ f ev st+  id .= st'

@@ -1,6 +1,7 @@ module Data.Component.MessageLayer where  import Control.Lens+import Control.Lens.TH.Rules import Control.Monad.State import Data.Aeson import Linear@@ -11,6 +12,20 @@ import qualified Data.Component.MessageEngine as CME import qualified SDL.Vect as Vect +data Config = Config {+  engine :: CME.Config,+  window :: CLayer.Config,+  next :: CAnim.Config+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    layerConf <- parseJSON =<< v .: "window"+    nextConf <- parseJSON =<< v .: "next"+    messageEngineConf <- parseJSON =<< v .: "engine"++    return $ Config messageEngineConf layerConf nextConf+ data MessageLayer = MessageLayer {   messageEngine :: CME.MessageEngine,   layer :: CLayer.Layer,@@ -18,6 +33,8 @@   config :: Config } +makeLensesWith lensRules_ ''MessageLayer+ engineL :: Lens' MessageLayer CME.MessageEngine engineL = lens messageEngine (\s a -> s { messageEngine = a }) @@ -48,19 +65,15 @@       ++ map (translate (position + Vect.V2 20 10)) textLayer       ++ map (translate (position + Vect.V2 ((windowSize ^. _x - cursorSize ^. _x) `div` 2) (windowSize ^. _y - cursorSize ^. _y))) cursorLayer -data Config = Config {-  engine :: CME.Config,-  window :: CLayer.Config,-  next :: CAnim.Config-}--instance FromJSON Config where-  parseJSON = withObject "config" $ \v -> do-    layerConf <- parseJSON =<< v .: "window"-    nextConf <- parseJSON =<< v .: "next"-    messageEngineConf <- parseJSON =<< v .: "engine"+  onSignal+    = Basic.wrapSignal (CLayer.basic . CLayer.config . layer)+    $ 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 -    return $ Config messageEngineConf layerConf nextConf+        go _ = return  new :: Config -> MiniLight MessageLayer new conf = do

@@ -4,7 +4,9 @@ import Control.Monad.State import Data.Aeson hiding ((.=)) import qualified Data.Config.Font as Font+import qualified Data.HashMap.Strict as HM import qualified Data.Text as T+import Data.Typeable (Typeable) import qualified Data.Vector as V import Linear import MiniLight@@ -39,11 +41,13 @@   useCache c1 c2 = hover c1 == hover c2    onSignal = Basic.wrapSignal (basic . conf) $ \ev sel -> flip execStateT sel $ do-    uid <- view uidL+    uid <- view _uid      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)       _ -> return ()    -- OMG@@ -61,8 +65,17 @@     Config       <$> parseJSON (Object v)       <*> v .:? "labels" .!= V.empty-      <*> parseJSON (Object v)+      <*> (parseJSON =<< (v .: "font"))       <*> v .: "image"++data SelectionEvent+  = Select Int+  deriving (Typeable)++instance EventType SelectionEvent where+  getEventType (Select _) = "select"++  getEventProperties (Select n) = HM.fromList [("index", Number $ fromIntegral n)]  new :: Config -> MiniLight Selection new conf = do

@@ -1,5 +1,6 @@ module Data.Config.Font where +import Control.Lens import Data.Aeson import Data.Word (Word8) import MiniLight@@ -12,20 +13,17 @@   color :: Vect.V4 Word8 } +makeLensesWith classyRules_ ''Config+ instance FromJSON Config where   parseJSON = withObject "font" $ \v -> do-    fontMaybe <- v .:? "font"--    case fontMaybe of-      Nothing -> return $ Config (FontDescriptor "" (FontStyle False False)) 0 (Vect.V4 0 0 0 255)-      Just w -> flip (withObject "font") w $ \v -> do-        family <- v .: "family"-        size <- v .: "size"-        bold <- v .:? "bold" .!= False-        italic <- v .:? "italic" .!= False-        [r,g,b,a] <- v .:? "color" .!= [0, 0, 0, 255]+    family <- v .:? "family" .!= ""+    size <- v .:? "size" .!= 0+    bold <- v .:? "bold" .!= False+    italic <- v .:? "italic" .!= False+    [r,g,b,a] <- v .:? "color" .!= [0, 0, 0, 255] -        return $ Config (FontDescriptor family (FontStyle bold italic)) size (Vect.V4 r g b a)+    return $ Config (FontDescriptor family (FontStyle bold italic)) size (Vect.V4 r g b a)  -- | Load a system font from 'Config' type. loadFontFrom :: Config -> MiniLight SDL.Font.Font

@@ -50,7 +50,7 @@   -> Int   -> a   -> IO ()-insert pvec@(IOVector _ uvec) i v = do+insert pvec i v = do   len <- safeLength pvec    read pvec (len - 1) >>= push pvec

@@ -6,6 +6,7 @@   module MiniLight.Event,   module MiniLight.Figure,   module MiniLight.Component,+  module MiniLight.Loader,    runLightT,   LoopState (..),@@ -29,12 +30,12 @@ import Data.IORef import qualified Data.Registry as R import qualified Data.Vector as V-import qualified Data.Text as T import Graphics.Text.TrueType import MiniLight.Component import MiniLight.Event import MiniLight.Figure import MiniLight.Light+import MiniLight.Loader import qualified System.FSNotify as Notify import qualified SDL import qualified SDL.Font@@ -62,7 +63,7 @@ -- | Use 'defConfig' for a default setting. data LoopConfig = LoopConfig {   watchKeys :: Maybe [SDL.Scancode],  -- ^ Set @Nothing@ if all keys should be watched. See also 'LoopState'.-  appConfigFile :: Maybe FilePath,  -- ^ Specify a yaml file which describes component settings. See 'MiniLight.Component' for the yaml syntax.+  appConfigFile :: Maybe FilePath,  -- ^ Specify a yaml file which describes component settings. See 'MiniLight.Loader' for the yaml syntax.   hotConfigReplacement :: Maybe FilePath,  -- ^ The directory path to be watched. If set, the config file modification will replace the component dynamically.   componentResolver :: Resolver,  -- ^ Your custom mappings between a component name and its type.   additionalComponents :: [Component]  -- ^ The components here would be added during the initialization.@@ -102,19 +103,24 @@   loaderEnv = _loader . loaderEnv  -instance HasLightEnv env' => HasLightEnv (env, env') where-  lightEnv = _2 . lightEnv+data ComponentState a = ComponentState {+  stateL :: a,+  componentEnvL :: ComponentEnv+} -instance HasLoopEnv env' => HasLoopEnv (env, env') where-  loopEnv = _2 . loopEnv+makeLensesWith classyRules_ ''ComponentState -instance HasLoaderEnv env' => HasLoaderEnv (env, env') where-  loaderEnv = _2 . loaderEnv+instance HasLightEnv env => HasLightEnv (ComponentState env) where+  lightEnv = _stateL . lightEnv +instance HasLoopEnv env => HasLoopEnv (ComponentState env) where+  loopEnv = _stateL . loopEnv -instance HasComponentEnv (T.Text, env) where-  uidL = _1+instance HasLoaderEnv env => HasLoaderEnv (ComponentState env) where+  loaderEnv = _stateL . loaderEnv +instance HasComponentEnv (ComponentState env) where+  componentEnv = _componentEnvL  -- | Same as 'runMainloop' but fixing the type. runMiniloop :: LoopConfig -> s -> (s -> MiniLoop s) -> MiniLight ()@@ -179,7 +185,12 @@     R.modifyV_ (loader ^. _registry) $ return . propagate      R.modifyV_ (loader ^. _registry) $ \comp ->-      envLightT (\env -> (getUID comp, conv env loop loader)) $ update comp+      envLightT+          ( \env -> ComponentState+            (conv env loop loader)+            (ComponentEnv (getUID comp) (getHooks comp))+          )+        $ update comp      s' <- envLightT (\env -> conv env loop loader) $ userloop s @@ -190,24 +201,21 @@     keys   <- SDL.getKeyboardState      envLightT (\env -> conv env loop loader) $ do-      evref   <- view _events-      sigref  <- view _signalQueue-      signals <- liftIO $ readIORef sigref-      liftIO-        $ modifyMVar_ evref-        $ return-        . (map RawEvent events ++)-        . (signals ++)-      liftIO $ writeIORef sigref []--    envLightT (\env -> conv env loop loader) $ do       evref  <- view _events       events <- liftIO $ modifyMVar evref (\a -> return ([], a))        R.modifyV_ (loader ^. _registry) $ \comp -> do-        foldlM (\comp ev -> envLightT ((,) (getUID comp)) $ onSignal ev comp)-               comp-               events+        foldlM+          ( \comp ev ->+            envLightT+                ( \env -> ComponentState+                  env+                  (ComponentEnv (getUID comp) (getHooks comp))+                )+              $ onSignal ev comp+          )+          comp+          events        forM_           ( catMaybes $ map@@ -220,6 +228,17 @@         $ \ev -> patchAppConfig             (fromJust $ appConfigFile conf)             (componentResolver conf)++    envLightT (\env -> conv env loop loader) $ do+      evref   <- view _events+      sigref  <- view _signalQueue+      signals <- liftIO $ readIORef sigref+      liftIO+        $ modifyMVar_ evref+        $ return+        . (map RawEvent events ++)+        . (signals ++)+      liftIO $ writeIORef sigref []      let loop' =           loop

@@ -1,47 +1,157 @@-{-| The package provides the configuration loader.+module MiniLight.Component (+  HookMap,+  HasComponentEnv(..),+  ComponentEnv(..),+  emit, -An configuration example:+  ComponentUnit(..),+  Component,+  newComponent,+  getComponentSize,+  getUID,+  getHooks,+  setHooks,+  propagate,+) where -@-_vars:-  window:-    width: 800-    height: 600-app:-  - name: message-layer-    properties:-      window:-        image: resources/window-base.png-        position:-          x: 0-          y: ${${var:window.height} - ${ref:..size.height}}-        size:-          width: ${var:window.width}-          height: 150-@+import Control.Lens+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import Data.IORef+import qualified Data.Text as T+import MiniLight.Light+import MiniLight.Event+import MiniLight.Figure+import qualified SDL -== Syntax+type HookMap = HM.HashMap T.Text (T.Text, Object -> Value) -=== @_vars@+-- | Environmental information, which are passed for each component+data ComponentEnv = ComponentEnv {+  uid :: T.Text,  -- ^ The unique id+  callbacks :: Maybe HookMap  -- ^ The hooks+} -You can define a new variable. Use object syntax under the @_vars@ field.+makeClassy_ ''ComponentEnv -The variables can be referenced in all siblings and under their siblings to the @_vars@, in the variable syntax @${var:_path_}@.+-- | Emit a signal, which will be catched at the next frame.+emit+  :: (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et)+  => et+  -> LightT env m ()+emit et = do+  uid <- view _uid+  ref <- view _signalQueue+  liftIO $ modifyIORef' ref $ (signal uid et :) -=== Expr+  hs <- view _callbacks+  case HM.lookup (getEventType et) =<< hs of+    Just (name, param) -> liftIO+      $ modifyIORef' ref (GlobalSignal name (param $ getEventProperties et) :)+    Nothing -> return () -In each field, you can specify an expression defined in the loader.+-- | CompoonentUnit typeclass provides a way to define a new component.+-- Any 'ComponentUnit' instance can be embedded into 'Component' type.+class ComponentUnit c where+  -- | Updating a model.+  update :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => c -> LightT env m c+  update = return -- @${}@: enclose the expr by @${}@, to tell the parsers that the field is an expr not a plain string.-- @${ref:_path_}@: specify any path to refer any other value. The path resolution is performed once, not recursively resolved. @_path_@ consists of field names splitted by a period. Use double dots @..@ for a parent.-- @${var:_path_}@: specify any path to value defined at the field. @_path_@ consists of field names splitted by a period.-- arithmetic operator: addition, subtraction, multiplication and division (@+,-,*,/@) can also be used in @${}@.+  -- | Descirbes a view. The figures here would be cached. See also 'useCache' for the cache configuration.+  figures :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m [Figure] --}-module MiniLight.Component (-  module MiniLight.Component.Types,-  module MiniLight.Component.Loader,-) where+  -- | Drawing a figures.+  draw :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m ()+  draw comp = liftMiniLight . renders =<< figures comp+  {-# INLINE draw #-} -import MiniLight.Component.Types-import MiniLight.Component.Loader+  -- | Event handlers+  onSignal :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => Event -> c -> LightT env m c+  onSignal _ = return++  -- | Return @True@ if a cache stored in the previous frame should be used.+  useCache+    :: c  -- ^ A model value in the previous frame+    -> c  -- ^ A model value in the current frame+    -> Bool+  useCache _ _ = False++  -- | To be called just before clearing caches.+  -- If you want to destroy cached textures for memory efficiency, override this method.+  --+  -- __NB__: Freeing SDL textures and figures are not performed automatically. You must call 'freeFigure' at your own risk.+  beforeClearCache :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> [Figure] -> LightT env m ()+  beforeClearCache _ _ = return ()++-- | A wrapper for 'ComponentUnit' instances.+data Component = forall c. ComponentUnit c => Component {+  uidOf :: T.Text,+  component :: c,+  prev :: c,+  cache :: IORef [Figure],+  callbackObject :: Maybe HookMap+}++-- | Create a new component.+newComponent+  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)+  => T.Text+  -> c+  -> LightT env m Component+newComponent uid c = do+  figs <- figures c+  ref  <- liftIO $ newIORef figs+  return $ Component+    { uidOf          = uid+    , component      = c+    , prev           = c+    , cache          = ref+    , callbackObject = Nothing+    }++-- | Get the size of a component.+getComponentSize+  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)+  => c+  -> LightT env m (SDL.Rectangle Int)+getComponentSize comp = do+  figs <- figures comp+  return $ foldl union (SDL.Rectangle (SDL.P 0) 0) $ map targetArea figs++-- | Get its unique id.+getUID :: Component -> T.Text+getUID (Component uid _ _ _ _) = uid++-- | Get the hooks+getHooks :: Component -> Maybe HookMap+getHooks (Component _ _ _ _ h) = h++-- | Get the hooks+setHooks :: Component -> Maybe HookMap -> Component+setHooks (Component uid comp prev cache _) h = Component uid comp prev cache h++-- | Clear the previous model cache and reflect the current model.+propagate :: Component -> Component+propagate (Component uid comp _ cache h) = Component uid comp comp cache h++instance ComponentUnit Component where+  update (Component uid comp prev cache h) = do+    comp' <- update comp+    return $ Component uid comp' prev cache h++  figures (Component _ comp _ _ _) = figures comp++  draw (Component _ comp prev ref _) = do+    if useCache prev comp+      then liftMiniLight . renders =<< liftIO (readIORef ref)+      else do+        figs <- liftIO (readIORef ref)+        beforeClearCache comp figs++        figs <- figures comp+        liftMiniLight $ renders figs+        liftIO $ writeIORef ref figs++  onSignal ev (Component uid comp prev cache h) = fmap (\comp' -> Component uid comp' prev cache h) $ onSignal ev comp

@@ -1,129 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-module MiniLight.Component.Internal.Resolver where--import Control.Applicative-import Data.Aeson hiding (Result)-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Data.Scientific (Scientific, fromFloatDigits)-import qualified Data.Vector as V-import Text.Trifecta--data Expr-  = None-  | Ref T.Text  -- ^ reference syntax: ${ref:...}-  | Var T.Text  -- ^ variable syntax: ${var:...}-  | Op T.Text Expr Expr  -- ^ expr operator: +, -, *, /-  | Constant Value  -- ^ constants (string or number or null)-  deriving (Eq, Show)--parser :: Parser Expr-parser = try reference <|> try variable <|> (char '$' *> braces (number <|> expr))- where-  expr      = chainl expr1 op1 None-  expr1     = chainl expr2 op2 None-  expr2     = parens expr <|> try reference <|> try variable <|> try number--  -- low precedence infixl operator group-  op1       = Op "+" <$ textSymbol "+" <|> Op "-" <$ textSymbol "-"--  -- high precedence infixl operator group-  op2       = Op "*" <$ textSymbol "*" <|> Op "/" <$ textSymbol "/"--  reference = do-    char '$'-    braces $ text "ref:" *> (fmap (Ref . T.pack) (many (letter <|> oneOf ".")))-  variable = do-    char '$'-    braces $ text "var:" *> (fmap (Var . T.pack) (many (letter <|> oneOf ".")))-  number = fmap (Constant . Number . either fromIntegral fromFloatDigits)-                integerOrDouble--data Context = Context {-  path :: V.Vector (Either Int T.Text),-  variables :: Object,-  target :: Value-}--getAt :: Value -> [Either Int T.Text] -> Value-getAt = go- where-  go value        [] = value-  go (Object obj) (Right key:ps) | key `HM.member` obj = go (obj HM.! key) ps-  go (Array  arr) (Left  i  :ps) | 0 <= i && i < V.length arr = go (arr V.! i) ps-  go v (p:_) =-    error-      $  "TypeError: path `"-      <> show p-      <> "` is missing in `"-      <> show v-      <> "`"--normalize-  :: V.Vector (Either Int T.Text) -> [Either Int T.Text] -> [Either Int T.Text]-normalize path1 ts = V.toList path1' ++ dropWhile (\v -> v == Right "") ts- where-  depth  = length $ takeWhile (\v -> v == Right "") ts-  path1' = V.take (V.length path1 - depth - 1) path1--pattern Arithmetic :: T.Text -> Scientific -> Scientific -> Expr-pattern Arithmetic op n1 n2 =-  Op op (Constant (Number n1)) (Constant (Number n2))--eval :: Context -> Expr -> Value-eval ctx = go- where-  go None = ""-  go (Ref path') =-    getAt (target ctx) (normalize (path ctx) (convertPath path'))-  go (Var path') =-    getAt (Object (variables ctx)) (normalize V.empty (convertPath path'))-  go (binds -> Arithmetic "+" n1 n2) = Number (n1+n2)-  go (binds -> Arithmetic "-" n1 n2) = Number (n1-n2)-  go (binds -> Arithmetic "*" n1 n2) = Number (n1*n2)-  go (binds -> Arithmetic "/" n1 n2) = Number (n1/n2)-  go expr = error $ "Illegal expression: " ++ show expr--  binds (Op op e1 e2) = Op op (Constant (eval ctx e1)) (Constant (eval ctx e2))-  binds _ = undefined--convertPath :: T.Text -> [Either Int T.Text]-convertPath-  = map-      ( \t ->-        foldResult (\_ -> Right t) (Left . fromIntegral) $ parseText index t-      )-    . T.splitOn "."-    . (\t -> if T.length t > 0 && T.head t == '.' then T.tail t else t)-  where index = char '[' *> natural <* char ']'--convert :: Context -> T.Text -> Value-convert ctx t = foldResult (\_ -> String t) (eval ctx) $ parseText parser t--parseText :: Parser a -> T.Text -> Result a-parseText parser = parseByteString parser mempty . TE.encodeUtf8--resolve :: Value -> Value-resolve = \value -> go (Context V.empty HM.empty value) value- where-  go ctx (Object obj)-    | "_vars" `HM.member` obj-    = let vars = obj HM.! "_vars"-      in  go-            ( ctx-              { variables = HM.union ((\(Object o) -> o) $ vars) (variables ctx)-              }-            )-            (Object (HM.delete "_vars" obj))-    | otherwise-    = Object $ HM.mapWithKey-      (\key -> go (ctx { path = V.snoc (path ctx) (Right key) }))-      obj-  go ctx (Array arr) =-    Array $ V.imap (\i -> go (ctx { path = V.snoc (path ctx) (Left i) })) arr-  go ctx (String t) = convert ctx t-  go _ (Number n) = Number n-  go _ (Bool   b) = Bool b-  go _ Null       = Null

@@ -1,50 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module MiniLight.Component.Internal.Types where--import Data.Aeson-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Data.UUID-import qualified Data.UUID.V4-import GHC.Generics-import MiniLight.Component.Types-import MiniLight.Light--data ComponentConfig = ComponentConfig {-  name :: T.Text,-  properties :: Value-} deriving (Eq, Show, Generic)--instance ToJSON ComponentConfig-instance FromJSON ComponentConfig--data AppConfig = AppConfig {-  app :: V.Vector ComponentConfig,-  uuid :: V.Vector T.Text-} deriving (Eq, Show)--instance FromJSON AppConfig where-  parseJSON = withObject "app" $ \v -> do-    app <- v .: "app"--    return $ AppConfig app V.empty---- | The type for component resolver-type Resolver-  = T.Text  -- ^ Component Type-  -> T.Text  -- ^ UID-  -> Value  -- ^ Component Property-  -> MiniLight (Either String Component)---- | Generate an unique id.-newUID :: MonadIO m => m T.Text-newUID = liftIO $ Data.UUID.toText <$> Data.UUID.V4.nextRandom---- | Create a component with given resolver.-createComponentBy-  :: Resolver-  -> Maybe T.Text-  -> ComponentConfig-  -> MiniLight (Either String Component)-createComponentBy resolver uid config =-  maybe newUID return uid >>= \u -> resolver (name config) u (properties config)

@@ -1,217 +0,0 @@-module MiniLight.Component.Loader (-  module MiniLight.Component.Internal.Types,--  LoaderEnv (..),-  HasLoaderEnv (..),--  resolveConfig,-  loadAppConfig,-  patchAppConfig,-) where--import Control.Lens-import Control.Monad-import qualified Control.Monad.Caster as Caster-import Control.Monad.Catch-import Control.Monad.Trans-import Control.Monad.Trans.Maybe-import Data.Aeson-import qualified Data.Aeson.Diff as Diff-import Data.Aeson.Patch-import Data.Aeson.Pointer-import Data.IORef-import qualified Data.Registry as R-import qualified Data.Vector as V-import Data.Yaml (decodeFileEither)-import MiniLight.Light-import MiniLight.Component.Types-import MiniLight.Component.Internal.Types-import MiniLight.Component.Internal.Resolver (resolve)---- | The environment for config loader-data LoaderEnv = LoaderEnv {-  registry :: R.Registry Component,-  appConfig :: IORef AppConfig-}--makeClassy_ ''LoaderEnv--toEither :: Result a -> Either String a-toEither (Error   s) = Left s-toEither (Success a) = Right a---- | Load an config file and return the resolved @AppConfig@.-resolveConfig :: MonadIO m => FilePath -> m (Either String AppConfig)-resolveConfig path =-  liftIO-    $   (toEither . fromJSON <=< fmap resolve)-    .   either (Left . show) Right-    <$> decodeFileEither path---- | Load an config file and set in the environment. Calling this function at once, this overrides all values in the environment.--- This will generate an error log and skip the component if the configuration is invalid.--- This function also assign unique IDs for each component, using 'assignUID'.-loadAppConfig-  :: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)-  => FilePath  -- ^ Filepath to the yaml file.-  -> Resolver  -- ^ Specify any resolver.-  -> LightT env m ()-loadAppConfig path mapper = fmap (maybe () id) $ runMaybeT $ do-  conf <- resolveConfig path >>= \case-    Left e -> do-      lift $ Caster.err e-      fail ""-    Right r -> return r--  confs <- lift $ fmap (V.mapMaybe id) $ V.forM (app conf) $ \conf -> do-    uid    <- newUID-    result <- liftMiniLight $ mapper (name conf) uid (properties conf)--    case result of-      Left e -> do-        Caster.err e-        return Nothing-      Right component -> do-        reg <- view _registry-        R.register reg uid component--        Caster.info-          $  "Component loaded: {name: "-          <> show (name conf)-          <> ", uid: "-          <> show uid-          <> "}"--        return $ Just (uid, conf)--  ref <- view _appConfig-  liftIO $ writeIORef ref $ AppConfig (V.map snd confs) (V.map fst confs)---- | Load the config file again and place the newly loaded components. This is used for HCR (hot component replacement).--- Call 'loadAppConfig' first.-patchAppConfig-  :: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)-  => FilePath  -- ^ Filepath to the yaml file.-  -> Resolver  -- ^ Specify any resolver.-  -> LightT env m ()-patchAppConfig path resolver = fmap (maybe () id) $ runMaybeT $ do-  cref      <- view _appConfig-  appConfig <- liftIO $ readIORef cref--  conf'     <- do-    mconf <- lift $ resolveConfig path--    case mconf of-      Left e -> do-        lift $ Caster.err e-        fail ""-      Right r -> return r--  lift-    $ forM_-        ( Diff.patchOperations-        $ Diff.diff (toJSON $ app appConfig) (toJSON $ app conf')-        )-    $ \op -> fmap (maybe () id) $ runMaybeT $ do-        lift $ Caster.debug $ "CMR detected: " <> show op--        case op of-          Add (Pointer [AKey n]) v      -> create n v-          Rem (Pointer [AKey n])        -> remove n-          Rep (Pointer [AKey n     ]) v -> modify n (Rep (Pointer []) v)-          Rep (Pointer (AKey n:path)) v -> modify n (Rep (Pointer path) v)-          Add (Pointer (AKey n:path)) v -> modify n (Add (Pointer path) v)-          Rem (Pointer (AKey n:path))   -> modify n (Rem (Pointer path))-          _ ->-            lift-              $  Caster.warn-              $  "CMR does not support the operation yet: "-              <> show op- where-  create n v = do-    cref     <- view _appConfig-    compConf <- case fromJSON v of-      Success a   -> return a-      Error   err -> do-        lift $ Caster.err err-        fail ""--    newID     <- lift newUID-    component <- do-      result <- lift $ liftMiniLight $ createComponentBy resolver-                                                         (Just newID)-                                                         compConf--      case result of-        Left err -> do-          lift $ Caster.err $ "Failed to resolve: " <> err-          fail ""-        Right c -> return c--    reg <- view _registry-    lift $ R.insert reg n (getUID component) component--    lift-      $  Caster.info-      $  "Component registered: {name: "-      <> show (name compConf)-      <> ", uid: "-      <> show (getUID component)-      <> "}"--    liftIO $ modifyIORef' cref $ \conf -> conf-      { app  = V.snoc (app conf) compConf-      , uuid = V.snoc (uuid conf) newID-      }--  remove n = do-    cref    <- view _appConfig-    appConf <- liftIO $ readIORef cref--    let uid = uuid appConf V.! n--    reg <- view _registry-    lift $ R.delete reg uid-    lift $ Caster.info $ "Component deleted: {uid: " <> show uid <> "}"--    liftIO $ writeIORef cref $ appConf-      { app  = V.ifilter (\i _ -> i /= n) $ app appConf-      , uuid = V.ifilter (\i _ -> i /= n) $ uuid appConf-      }--  modify n op = do-    cref     <- view _appConfig-    appConf  <- liftIO $ readIORef cref--    compConf <--      case Diff.applyOperation op (toJSON (app appConf V.! n)) >>= fromJSON of-        Success a   -> return a-        Error   err -> do-          lift $ Caster.err err-          fail ""--    let uid = uuid appConf V.! n--    component <- do-      result <- lift $ liftMiniLight $ createComponentBy resolver-                                                         (Just uid)-                                                         compConf--      case result of-        Left err -> do-          lift $ Caster.err $ "Failed to resolve: " <> err-          fail ""-        Right c -> return c--    reg <- view _registry-    lift $ R.write reg uid component-    lift-      $  Caster.info-      $  "Component replaced: {name: "-      <> show (name compConf)-      <> ", uid: "-      <> show (getUID component)-      <> "}"--    liftIO $ writeIORef cref $ appConf { app = app appConf V.// [(n, compConf)]-                                       }

@@ -1,125 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-module MiniLight.Component.Types (-  HasComponentEnv(..),-  emit,--  ComponentUnit(..),-  Component,-  newComponent,-  getComponentSize,-  getUID,-  propagate,-) where--import Control.Lens-import Control.Monad.Catch-import Control.Monad.IO.Class-import Data.IORef-import qualified Data.Text as T-import MiniLight.Light-import MiniLight.Event-import MiniLight.Figure-import qualified SDL--class HasComponentEnv env where-  -- | Lens to the unique id, which is provided for each component.-  uidL :: Lens' env T.Text---- | Emit a signal, which will be catched at the next frame.-emit-  :: (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et)-  => et-  -> LightT env m ()-emit et = do-  uid <- view uidL-  ref <- view _signalQueue-  liftIO $ modifyIORef' ref $ (signal uid et :)---- | CompoonentUnit typeclass provides a way to define a new component.--- Any 'ComponentUnit' instance can be embedded into 'Component' type.-class ComponentUnit c where-  -- | Updating a model.-  update :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => c -> LightT env m c-  update = return--  -- | Descirbes a view. The figures here would be cached. See also 'useCache' for the cache configuration.-  figures :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m [Figure]--  -- | Drawing a figures.-  draw :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m ()-  draw comp = liftMiniLight . renders =<< figures comp-  {-# INLINE draw #-}--  -- | Event handlers-  onSignal :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => Event -> c -> LightT env m c-  onSignal _ = return--  -- | Return @True@ if a cache stored in the previous frame should be used.-  useCache-    :: c  -- ^ A model value in the previous frame-    -> c  -- ^ A model value in the current frame-    -> Bool-  useCache _ _ = False--  -- | To be called just before clearing caches.-  -- If you want to destroy cached textures for memory efficiency, override this method.-  ---  -- __NB__: Freeing SDL textures and figures are not performed automatically. You must call 'freeFigure' at your own risk.-  beforeClearCache :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> [Figure] -> LightT env m ()-  beforeClearCache _ _ = return ()---- | A wrapper for 'ComponentUnit' instances.-data Component = forall c. ComponentUnit c => Component {-  uid :: T.Text,-  component :: c,-  prev :: c,-  cache :: IORef [Figure]-}---- | Create a new component.-newComponent-  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)-  => T.Text-  -> c-  -> LightT env m Component-newComponent uid c = do-  figs <- figures c-  ref  <- liftIO $ newIORef figs-  return $ Component {uid = uid, component = c, prev = c, cache = ref}---- | Get the size of a component.-getComponentSize-  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)-  => c-  -> LightT env m (SDL.Rectangle Int)-getComponentSize comp = do-  figs <- figures comp-  return $ foldl union (SDL.Rectangle (SDL.P 0) 0) $ map targetArea figs---- | Get its unique id.-getUID :: Component -> T.Text-getUID (Component uid _ _ _) = uid---- | Clear the previous model cache and reflect the current model.-propagate :: Component -> Component-propagate (Component uid comp _ cache) = Component uid comp comp cache--instance ComponentUnit Component where-  update (Component uid comp prev cache) = do-    comp' <- update comp-    return $ Component uid comp' prev cache--  figures (Component _ comp _ _) = figures comp--  draw (Component _ comp prev ref) = do-    if useCache prev comp-      then liftMiniLight . renders =<< liftIO (readIORef ref)-      else do-        figs <- liftIO (readIORef ref)-        beforeClearCache comp figs--        figs <- figures comp-        liftMiniLight $ renders figs-        liftIO $ writeIORef ref figs--  onSignal ev (Component uid comp prev cache) = fmap (\comp' -> Component uid comp' prev cache) $ onSignal ev comp

@@ -1,23 +1,32 @@+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module MiniLight.Event (   Event (..),-  EventType,+  EventType (..),   signal,   asSignal, ) where  import qualified SDL+import Data.Aeson+import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Data.Type.Equality import Type.Reflection import qualified System.FSNotify as Notify  -- | EventType says some type can be used as an event type.-class Typeable e => EventType e+class Typeable e => EventType e where+  getEventType :: e -> T.Text+  default getEventType :: Show e => e -> T.Text+  getEventType = T.pack . show +  getEventProperties :: e -> Object+  getEventProperties _ = HM.empty+ -- | This type is same as 'Dynamic' from @Data.Dynamic@, but it requires 'EventType' contraint. data Dynamic where   Dynamic :: forall a. EventType a => TypeRep a -> a -> Dynamic@@ -32,8 +41,8 @@  -- | Event type representation data Event-  = Never-  | Signal T.Text Dynamic+  = Signal T.Text Dynamic+  | GlobalSignal T.Text Value   | RawEvent SDL.Event   | NotifyEvent Notify.Event 

@@ -0,0 +1,279 @@+{-| The package provides the configuration loader.++An configuration example:++@+_vars:+  window:+    width: 800+    height: 600+app:+  - name: message-layer+    properties:+      window:+        image: resources/window-base.png+        position:+          x: 0+          y: ${${var:window.height} - ${ref:..size.height}}+        size:+          width: ${var:window.width}+          height: 150+@++== Syntax++=== @_vars@++You can define a new variable. Use object syntax under the @_vars@ field.++The variables can be referenced in all siblings and under their siblings to the @_vars@, in the variable syntax @${var:_path_}@.++=== Expr++In each field, you can specify an expression defined in the loader.++- @${}@: enclose the expr by @${}@, to tell the parsers that the field is an expr not a plain string.+- @${ref:_path_}@: specify any path to refer any other value. The path resolution is performed once, not recursively resolved. @_path_@ consists of field names splitted by a period. Use double dots @..@ for a parent.+- @${var:_path_}@: specify any path to value defined at the field. @_path_@ consists of field names splitted by a period.+- arithmetic operator: addition, subtraction, multiplication and division (@+,-,*,/@) can also be used in @${}@.++-}+module MiniLight.Loader (+  module MiniLight.Loader.Internal.Types,+  createComponentBy,++  LoaderEnv (..),+  HasLoaderEnv (..),++  resolveConfig,+  loadAppConfig,+  patchAppConfig,++  resolve,+  parseAppConfig,+) where++import Control.Lens+import Control.Monad+import qualified Control.Monad.Caster as Caster+import Control.Monad.Catch+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Data.Aeson+import qualified Data.Aeson.Diff as Diff+import Data.Aeson.Patch+import Data.Aeson.Pointer+import Data.IORef+import qualified Data.Registry as R+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Yaml (decodeFileEither)+import MiniLight.Light+import MiniLight.Component+import MiniLight.Loader.Internal.Types+import MiniLight.Loader.Internal.Resolver (resolve, resolveWith, parseAppConfig, emptyContext, Context(..))++-- | Create a component with given resolver.+createComponentBy+  :: Resolver+  -> Maybe T.Text+  -> ComponentConfig+  -> MiniLight (Either String Component)+createComponentBy resolver uid config = do+  uuid   <- maybe newUID return uid+  result <- resolver (name config) uuid (properties config)+  return $ fmap+    ( \c -> setHooks+      c+      ( fmap+          ( fmap $ \hk -> (,) (signalName hk) $ \evprops ->+            (\(Right r) -> r)+              $ resolveWith (emptyContext { values = evprops }) (parameter hk)+          )+      $ hooks config+      )+    )+    result++-- | The environment for config loader+data LoaderEnv = LoaderEnv {+  registry :: R.Registry Component,+  appConfig :: IORef AppConfig+}++makeClassy_ ''LoaderEnv++-- | Load an config file and return the resolved @AppConfig@.+resolveConfig :: MonadIO m => FilePath -> m (Either T.Text AppConfig)+resolveConfig path =+  liftIO+    $   (parseAppConfig <=< either (Left . T.pack . show) Right)+    <$> decodeFileEither path++-- | Load an config file and set in the environment. Calling this function at once, this overrides all values in the environment.+-- This will generate an error log and skip the component if the configuration is invalid.+-- This function also assign unique IDs for each component, using 'assignUID'.+loadAppConfig+  :: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)+  => FilePath  -- ^ Filepath to the yaml file.+  -> Resolver  -- ^ Specify any resolver.+  -> LightT env m ()+loadAppConfig path mapper = fmap (maybe () id) $ runMaybeT $ do+  conf <- resolveConfig path >>= \case+    Left e -> do+      lift $ Caster.err e+      fail ""+    Right r -> return r++  confs <- lift $ fmap (V.mapMaybe id) $ V.forM (app conf) $ \conf -> do+    uid    <- newUID+    result <- liftMiniLight $ createComponentBy mapper (Just uid) conf++    case result of+      Left e -> do+        Caster.err e+        return Nothing+      Right component -> do+        reg <- view _registry+        R.register reg uid component++        Caster.info+          $  "Component loaded: {name: "+          <> show (name conf)+          <> ", uid: "+          <> show uid+          <> "}"++        return $ Just (uid, conf)++  ref <- view _appConfig+  liftIO $ writeIORef ref $ AppConfig (V.map snd confs) (V.map fst confs)++-- | Load the config file again and place the newly loaded components. This is used for HCR (hot component replacement).+-- Call 'loadAppConfig' first.+patchAppConfig+  :: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)+  => FilePath  -- ^ Filepath to the yaml file.+  -> Resolver  -- ^ Specify any resolver.+  -> LightT env m ()+patchAppConfig path resolver = fmap (maybe () id) $ runMaybeT $ do+  cref      <- view _appConfig+  appConfig <- liftIO $ readIORef cref++  conf'     <- do+    mconf <- lift $ resolveConfig path++    case mconf of+      Left e -> do+        lift $ Caster.err e+        fail ""+      Right r -> return r++  lift+    $ forM_+        ( Diff.patchOperations+        $ Diff.diff (toJSON $ app appConfig) (toJSON $ app conf')+        )+    $ \op -> fmap (maybe () id) $ runMaybeT $ do+        lift $ Caster.debug $ "CMR detected: " <> show op++        case op of+          Add (Pointer [AKey n]) v      -> create n v+          Rem (Pointer [AKey n])        -> remove n+          Rep (Pointer [AKey n     ]) v -> modify n (Rep (Pointer []) v)+          Rep (Pointer (AKey n:path)) v -> modify n (Rep (Pointer path) v)+          Add (Pointer (AKey n:path)) v -> modify n (Add (Pointer path) v)+          Rem (Pointer (AKey n:path))   -> modify n (Rem (Pointer path))+          _ ->+            lift+              $  Caster.warn+              $  "CMR does not support the operation yet: "+              <> show op+ where+  create n v = do+    cref     <- view _appConfig+    compConf <- case fromJSON v of+      Success a   -> return a+      Error   err -> do+        lift $ Caster.err err+        fail ""++    newID     <- lift newUID+    component <- do+      result <- lift $ liftMiniLight $ createComponentBy resolver+                                                         (Just newID)+                                                         compConf++      case result of+        Left err -> do+          lift $ Caster.err $ "Failed to resolve: " <> err+          fail ""+        Right c -> return c++    reg <- view _registry+    lift $ R.insert reg n (getUID component) component++    lift+      $  Caster.info+      $  "Component registered: {name: "+      <> show (name compConf)+      <> ", uid: "+      <> show (getUID component)+      <> "}"++    liftIO $ modifyIORef' cref $ \conf -> conf+      { app  = V.snoc (app conf) compConf+      , uuid = V.snoc (uuid conf) newID+      }++  remove n = do+    cref    <- view _appConfig+    appConf <- liftIO $ readIORef cref++    let uid = uuid appConf V.! n++    reg <- view _registry+    lift $ R.delete reg uid+    lift $ Caster.info $ "Component deleted: {uid: " <> show uid <> "}"++    liftIO $ writeIORef cref $ appConf+      { app  = V.ifilter (\i _ -> i /= n) $ app appConf+      , uuid = V.ifilter (\i _ -> i /= n) $ uuid appConf+      }++  modify n op = do+    cref     <- view _appConfig+    appConf  <- liftIO $ readIORef cref++    compConf <-+      case Diff.applyOperation op (toJSON (app appConf V.! n)) >>= fromJSON of+        Success a   -> return a+        Error   err -> do+          lift $ Caster.err err+          fail ""++    let uid = uuid appConf V.! n++    component <- do+      result <- lift $ liftMiniLight $ createComponentBy resolver+                                                         (Just uid)+                                                         compConf++      case result of+        Left err -> do+          lift $ Caster.err $ "Failed to resolve: " <> err+          fail ""+        Right c -> return c++    reg <- view _registry+    lift $ R.write reg uid component+    lift+      $  Caster.info+      $  "Component replaced: {name: "+      <> show (name compConf)+      <> ", uid: "+      <> show (getUID component)+      <> "}"++    liftIO $ writeIORef cref $ appConf { app = app appConf V.// [(n, compConf)]+                                       }

@@ -0,0 +1,223 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module MiniLight.Loader.Internal.Resolver where++import Control.Applicative+import Control.Monad+import Data.Aeson hiding (Result)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Scientific (fromFloatDigits)+import qualified Data.Vector as V+import GHC.Generics (Generic)+import MiniLight.Loader.Internal.Types+import Text.Trifecta++data Expr+  = None+  | Ref T.Text  -- ^ reference syntax: ${ref:...}+  | Var T.Text  -- ^ variable syntax: ${var:...}+  | Op T.Text Expr Expr  -- ^ expr operator: +, -, *, /+  | Constant Value  -- ^ constants (string or number or null)+  | Symbol T.Text  -- ^ token symbol+  | App Expr [Expr]  -- ^ function application ($func(a,b,c))+  deriving (Eq, Show, Generic)++instance ToJSON Expr+instance FromJSON Expr++parser :: Parser Expr+parser = try reference <|> try variable <|> try (char '$' *> braces expr)+ where+  expr  = chainl expr1 op1 None+  expr1 = chainl expr2 op2 None+  expr2 =+    parens expr+      <|> try apply+      <|> try parameter+      <|> try reference+      <|> try variable+      <|> try number+      <|> try strlit++  -- low precedence infixl operator group+  op1       = Op "+" <$ textSymbol "+" <|> Op "-" <$ textSymbol "-"++  -- high precedence infixl operator group+  op2       = Op "*" <$ textSymbol "*" <|> Op "/" <$ textSymbol "/"++  reference = char '$' *> do+    braces $ text "ref:" *> (fmap (Ref . T.pack) (many (letter <|> oneOf ".")))+  variable = char '$' *> do+    braces $ text "var:" *> (fmap (Var . T.pack) (many (letter <|> oneOf ".")))+  number = fmap (Constant . Number . either fromIntegral fromFloatDigits)+                integerOrDouble+  strlit    = fmap (Constant . String) $ stringLiteral++  parameter = char '$' *> do+    fmap (Symbol . T.pack) $ (:) <$> letter <*> many (letter <|> digit)+  apply = do+    func <- parameter+    exps <-+      parens+      $       option []+      $       fmap (filter (/= None))+      $       try+      $       (:)+      <$>     expr+      <*>     expr+      `sepBy` (char ',')+    return $ App func exps++data Context = Context {+  path :: V.Vector (Either Int T.Text),+  variables :: Object,+  values :: HM.HashMap T.Text Value+}++emptyContext :: Context+emptyContext = Context V.empty HM.empty HM.empty++getAt :: Value -> [Either Int T.Text] -> Either T.Text Value+getAt = go+ where+  go value        [] = Right value+  go (Object obj) (Right key:ps) | key `HM.member` obj = go (obj HM.! key) ps+  go (Array  arr) (Left  i  :ps) | 0 <= i && i < V.length arr = go (arr V.! i) ps+  go v (p:_) =+    Left+      $  "TypeError: path `"+      <> T.pack (show p)+      <> "` is missing in `"+      <> T.pack (show v)+      <> "`"++normalize+  :: V.Vector (Either Int T.Text) -> [Either Int T.Text] -> [Either Int T.Text]+normalize path1 ts = V.toList path1' ++ dropWhile (\v -> v == Right "") ts+ where+  depth  = length $ takeWhile (\v -> v == Right "") ts+  path1' = V.take (V.length path1 - depth - 1) path1++eval :: Context -> Value -> Expr -> Either T.Text Value+eval ctx target = go+ where+  go None = Right ""+  go (Ref path') =+    either (Left . (("Error in `${ref:" <> path' <> "}`\n") <>)) Right+      $ getAt target (normalize (path ctx) (convertPath path'))+  go (Var path') =+    either (Left . (("Error in `${var:" <> path' <> "}`\n") <>)) Right+      $ getAt (Object (variables ctx)) (normalize V.empty (convertPath path'))+  go (Op "+" e1 e2) = runOp (+) e1 e2+  go (Op "-" e1 e2) = runOp (-) e1 e2+  go (Op "*" e1 e2) = runOp (*) e1 e2+  go (Op "/" e1 e2) = runOp (/) e1 e2+  go (Symbol t) =+    maybe (Left $ "Symbol not defined: `" <> t <> "`") Right+      $ HM.lookup t+      $ values ctx+  go expr = Left $ "Illegal expression: " <> T.pack (show expr)++  runOp op e1 e2 =+    fmap Number+      $   join+      $   (\x y -> op <$> asNumber x <*> asNumber y)+      <$> go e1+      <*> go e2++  asNumber (Number x) = Right x+  asNumber x          = Left $ "Not a number: " <> T.pack (show x)++convertPath :: T.Text -> [Either Int T.Text]+convertPath =+  map (\t -> either (\_ -> Right t) (Left . fromIntegral) $ parseText index t)+    . T.splitOn "."+    . (\t -> if T.length t > 0 && T.head t == '.' then T.tail t else t)+  where index = char '[' *> natural <* char ']'++convert :: Context -> Value -> T.Text -> Either T.Text Value+convert ctx target t =+  either (\_ -> Right $ String t) (eval ctx target) $ parseText parser t++parseText :: Parser a -> T.Text -> Either T.Text a+parseText parser =+  foldResult (Left . T.pack . show) Right+    . parseByteString parser mempty+    . TE.encodeUtf8++resolveWith :: Context -> Value -> Either T.Text Value+resolveWith ctx target = go ctx target+ where+  go ctx (Object obj)+    | "_vars" `HM.member` obj+    = let vars = obj HM.! "_vars"+      in  go+            ( ctx+              { variables = HM.union ((\(Object o) -> o) $ vars) (variables ctx)+              }+            )+            (Object (HM.delete "_vars" obj))+    | otherwise+    = fmap Object $ sequence $ HM.mapWithKey+      (\key -> go (ctx { path = V.snoc (path ctx) (Right key) }))+      obj+  go ctx (Array arr) = fmap Array $ sequence $ V.imap+    (\i -> go (ctx { path = V.snoc (path ctx) (Left i) }))+    arr+  go ctx (String t) = convert ctx target t+  go _   (Number n) = Right $ Number n+  go _   (Bool   b) = Right $ Bool b+  go _   Null       = Right Null++-- | Interpret a JSON value, and unsafely apply fromRight+resolve :: Value -> Value+resolve = (\(Right a) -> a) . resolveWith emptyContext++-- | Create 'AppConfig' value from JSON value+parseAppConfig :: Value -> Either T.Text AppConfig+parseAppConfig = conf (Context V.empty HM.empty HM.empty)+ where+  conf :: Context -> Value -> Either T.Text AppConfig+  conf ctx (Object obj) | "app" `HM.member` obj =+    let+      ctx' = maybe+        ctx+        ( \vars -> ctx+          { variables = HM.union ((\(Object o) -> o) vars) (variables ctx)+          }+        )+        (HM.lookup "_vars" obj)+    in+      fmap (\v -> AppConfig v V.empty) $ app ctx' (obj HM.! "app")+  conf _ (Object obj) =+    Left $ "path `app` is missing in " <> T.pack (show (Object obj))+  conf _ ast = Left $ "Invalid format: " <> T.pack (show ast)++  app :: Context -> Value -> Either T.Text (V.Vector ComponentConfig)+  app ctx (Array vec) = V.mapM (component ctx) vec+  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+    let+      ctx' = maybe+        ctx+        ( \vars -> ctx+          { variables = HM.union ((\(Object o) -> o) vars) (variables ctx)+          }+        )+        (HM.lookup "_vars" obj)++    nameValue <- resolveWith ctx' (obj HM.! "name")+    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+      _ -> Left $ "Invalid format: " <> T.pack (show nameValue)+  component _ ast = Left $ "Invalid format: " <> T.pack (show ast)

@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveGeneric #-}+module MiniLight.Loader.Internal.Types where++import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.UUID+import qualified Data.UUID.V4+import GHC.Generics (Generic)+import MiniLight.Component+import MiniLight.Light++data Hook = Hook {+  signalName :: T.Text,+  parameter :: Value+} deriving (Show, Generic)++instance ToJSON Hook++instance FromJSON Hook where+  parseJSON = withObject "hook" $ \v ->+    Hook <$> v .: "name" <*> v .: "parameter"++toHook :: Value -> Either T.Text Hook+toHook =+  ( \case+      Success a   -> Right a+      Error   err -> Left $ T.pack $ show err+    )+    . fromJSON++-- | A configuration for a component+data ComponentConfig = ComponentConfig {+  name :: 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)]++instance FromJSON ComponentConfig where+  parseJSON = withObject "component" $ \v -> do+    name <- v .: "name"+    props <- v .: "properties"++    return $ ComponentConfig name props Nothing++-- | A configuration for the application itself+data AppConfig = AppConfig {+  app :: V.Vector ComponentConfig,+  uuid :: V.Vector T.Text+}++instance FromJSON AppConfig where+  parseJSON = withObject "app" $ \v -> do+    app <- v .: "app"++    return $ AppConfig app V.empty++-- | The type for component resolver+type Resolver+  = T.Text  -- ^ Component Type+  -> T.Text  -- ^ UID+  -> Value  -- ^ Component Property+  -> MiniLight (Either String Component)++-- | Generate an unique id.+newUID :: MonadIO m => m T.Text+newUID = liftIO $ Data.UUID.toText <$> Data.UUID.V4.nextRandom