diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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`. diff --git a/minilight.cabal b/minilight.cabal --- a/minilight.cabal +++ b/minilight.cabal @@ -3,7 +3,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/ name: minilight -version: 0.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 diff --git a/src/Control/Lens/TH/Rules.hs b/src/Control/Lens/TH/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/TH/Rules.hs @@ -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))] diff --git a/src/Data/Component/Basic.hs b/src/Data/Component/Basic.hs --- a/src/Data/Component/Basic.hs +++ b/src/Data/Component/Basic.hs @@ -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] diff --git a/src/Data/Component/Button.hs b/src/Data/Component/Button.hs --- a/src/Data/Component/Button.hs +++ b/src/Data/Component/Button.hs @@ -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 diff --git a/src/Data/Component/Layer.hs b/src/Data/Component/Layer.hs --- a/src/Data/Component/Layer.hs +++ b/src/Data/Component/Layer.hs @@ -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 diff --git a/src/Data/Component/MessageEngine.hs b/src/Data/Component/MessageEngine.hs --- a/src/Data/Component/MessageEngine.hs +++ b/src/Data/Component/MessageEngine.hs @@ -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' diff --git a/src/Data/Component/MessageLayer.hs b/src/Data/Component/MessageLayer.hs --- a/src/Data/Component/MessageLayer.hs +++ b/src/Data/Component/MessageLayer.hs @@ -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 diff --git a/src/Data/Component/Selection.hs b/src/Data/Component/Selection.hs --- a/src/Data/Component/Selection.hs +++ b/src/Data/Component/Selection.hs @@ -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 diff --git a/src/Data/Config/Font.hs b/src/Data/Config/Font.hs --- a/src/Data/Config/Font.hs +++ b/src/Data/Config/Font.hs @@ -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 diff --git a/src/Data/Vector/Mutable/PushBack.hs b/src/Data/Vector/Mutable/PushBack.hs --- a/src/Data/Vector/Mutable/PushBack.hs +++ b/src/Data/Vector/Mutable/PushBack.hs @@ -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 diff --git a/src/MiniLight.hs b/src/MiniLight.hs --- a/src/MiniLight.hs +++ b/src/MiniLight.hs @@ -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 diff --git a/src/MiniLight/Component.hs b/src/MiniLight/Component.hs --- a/src/MiniLight/Component.hs +++ b/src/MiniLight/Component.hs @@ -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 diff --git a/src/MiniLight/Component/Internal/Resolver.hs b/src/MiniLight/Component/Internal/Resolver.hs deleted file mode 100644 --- a/src/MiniLight/Component/Internal/Resolver.hs +++ /dev/null @@ -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 diff --git a/src/MiniLight/Component/Internal/Types.hs b/src/MiniLight/Component/Internal/Types.hs deleted file mode 100644 --- a/src/MiniLight/Component/Internal/Types.hs +++ /dev/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) diff --git a/src/MiniLight/Component/Loader.hs b/src/MiniLight/Component/Loader.hs deleted file mode 100644 --- a/src/MiniLight/Component/Loader.hs +++ /dev/null @@ -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)] - } diff --git a/src/MiniLight/Component/Types.hs b/src/MiniLight/Component/Types.hs deleted file mode 100644 --- a/src/MiniLight/Component/Types.hs +++ /dev/null @@ -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 diff --git a/src/MiniLight/Event.hs b/src/MiniLight/Event.hs --- a/src/MiniLight/Event.hs +++ b/src/MiniLight/Event.hs @@ -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 diff --git a/src/MiniLight/Loader.hs b/src/MiniLight/Loader.hs new file mode 100644 --- /dev/null +++ b/src/MiniLight/Loader.hs @@ -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)] + } diff --git a/src/MiniLight/Loader/Internal/Resolver.hs b/src/MiniLight/Loader/Internal/Resolver.hs new file mode 100644 --- /dev/null +++ b/src/MiniLight/Loader/Internal/Resolver.hs @@ -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) diff --git a/src/MiniLight/Loader/Internal/Types.hs b/src/MiniLight/Loader/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/MiniLight/Loader/Internal/Types.hs @@ -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