module MiniLight.Loader (
module MiniLight.Loader.Internal.Types,
createComponentBy,
lookupByTagID,
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.HashMap.Strict as HM
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(..))
data LoaderEnv = LoaderEnv {
LoaderEnv -> Registry Component
registry :: R.Registry Component,
LoaderEnv -> IORef (HashMap Text Text)
tagRegistry :: IORef (HM.HashMap T.Text T.Text),
LoaderEnv -> IORef AppConfig
appConfig :: IORef AppConfig
}
makeClassy_ ''LoaderEnv
createComponentBy
:: (HasLoaderEnv env, HasLightEnv env, MonadIO m)
=> Resolver
-> Maybe T.Text
-> ComponentConfig
-> LightT env m (Either String Component)
createComponentBy :: Resolver
-> Maybe Text
-> ComponentConfig
-> LightT env m (Either String Component)
createComponentBy resolver :: Resolver
resolver uid :: Maybe Text
uid config :: ComponentConfig
config = do
Text
uuid <- LightT env m Text
-> (Text -> LightT env m Text) -> Maybe Text -> LightT env m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LightT env m Text
forall (m :: * -> *). MonadIO m => m Text
newUID Text -> LightT env m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
uid
Either String Component
result <- MiniLight (Either String Component)
-> LightT env m (Either String Component)
forall env (m :: * -> *) a.
(HasLightEnv env, MonadIO m) =>
MiniLight a -> LightT env m a
liftMiniLight
(MiniLight (Either String Component)
-> LightT env m (Either String Component))
-> MiniLight (Either String Component)
-> LightT env m (Either String Component)
forall a b. (a -> b) -> a -> b
$ Resolver
resolver (ComponentConfig -> Text
componentType ComponentConfig
config) Text
uuid (ComponentConfig -> Value
properties ComponentConfig
config)
case ComponentConfig -> Maybe Text
tagID ComponentConfig
config of
Just tag :: Text
tag -> do
IORef (HashMap Text Text)
regRef <- Getting (IORef (HashMap Text Text)) env (IORef (HashMap Text Text))
-> LightT env m (IORef (HashMap Text Text))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef (HashMap Text Text)) env (IORef (HashMap Text Text))
forall c. HasLoaderEnv c => Lens' c (IORef (HashMap Text Text))
_tagRegistry
IO () -> LightT env m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LightT env m ()) -> IO () -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap Text Text)
-> (HashMap Text Text -> HashMap Text Text) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap Text Text)
regRef ((HashMap Text Text -> HashMap Text Text) -> IO ())
-> (HashMap Text Text -> HashMap Text Text) -> IO ()
forall a b. (a -> b) -> a -> b
$ \reg :: HashMap Text Text
reg -> Text -> Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
tag Text
uuid HashMap Text Text
reg
String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.debug (String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "TagID registered: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
tag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
uuid
_ -> () -> LightT env m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Either String Component -> LightT env m (Either String Component)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Component -> LightT env m (Either String Component))
-> Either String Component
-> LightT env m (Either String Component)
forall a b. (a -> b) -> a -> b
$ (Component -> Component)
-> Either String Component -> Either String Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
( \c :: Component
c -> Component -> Maybe HookMap -> Component
setHooks
Component
c
( (HashMap Text Hook -> HookMap)
-> Maybe (HashMap Text Hook) -> Maybe HookMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
( (Hook -> (Text, HashMap Text Value -> Value))
-> HashMap Text Hook -> HookMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Hook -> (Text, HashMap Text Value -> Value))
-> HashMap Text Hook -> HookMap)
-> (Hook -> (Text, HashMap Text Value -> Value))
-> HashMap Text Hook
-> HookMap
forall a b. (a -> b) -> a -> b
$ \hk :: Hook
hk -> (,) (Hook -> Text
signalName Hook
hk) ((HashMap Text Value -> Value)
-> (Text, HashMap Text Value -> Value))
-> (HashMap Text Value -> Value)
-> (Text, HashMap Text Value -> Value)
forall a b. (a -> b) -> a -> b
$ \evprops :: HashMap Text Value
evprops ->
(\(Right r :: Value
r) -> Value
r)
(Either Text Value -> Value) -> Either Text Value -> Value
forall a b. (a -> b) -> a -> b
$ Context -> Value -> Either Text Value
resolveWith (Context
emptyContext { values :: HashMap Text Value
values = HashMap Text Value
evprops }) (Hook -> Value
parameter Hook
hk)
)
(Maybe (HashMap Text Hook) -> Maybe HookMap)
-> Maybe (HashMap Text Hook) -> Maybe HookMap
forall a b. (a -> b) -> a -> b
$ ComponentConfig -> Maybe (HashMap Text Hook)
hooks ComponentConfig
config
)
)
Either String Component
result
lookupByTagID
:: (HasLightEnv env, HasLoaderEnv env, MonadIO m)
=> T.Text
-> LightT env m (Maybe T.Text)
lookupByTagID :: Text -> LightT env m (Maybe Text)
lookupByTagID tag :: Text
tag = do
IORef (HashMap Text Text)
regRef <- Getting (IORef (HashMap Text Text)) env (IORef (HashMap Text Text))
-> LightT env m (IORef (HashMap Text Text))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef (HashMap Text Text)) env (IORef (HashMap Text Text))
forall c. HasLoaderEnv c => Lens' c (IORef (HashMap Text Text))
_tagRegistry
HashMap Text Text
reg <- IO (HashMap Text Text) -> LightT env m (HashMap Text Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap Text Text) -> LightT env m (HashMap Text Text))
-> IO (HashMap Text Text) -> LightT env m (HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ IORef (HashMap Text Text) -> IO (HashMap Text Text)
forall a. IORef a -> IO a
readIORef IORef (HashMap Text Text)
regRef
Maybe Text -> LightT env m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> LightT env m (Maybe Text))
-> Maybe Text -> LightT env m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
tag HashMap Text Text
reg
resolveConfig :: MonadIO m => FilePath -> m (Either T.Text AppConfig)
resolveConfig :: String -> m (Either Text AppConfig)
resolveConfig path :: String
path =
IO (Either Text AppConfig) -> m (Either Text AppConfig)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO (Either Text AppConfig) -> m (Either Text AppConfig))
-> IO (Either Text AppConfig) -> m (Either Text AppConfig)
forall a b. (a -> b) -> a -> b
$ (Value -> Either Text AppConfig
parseAppConfig (Value -> Either Text AppConfig)
-> (Either ParseException Value -> Either Text Value)
-> Either ParseException Value
-> Either Text AppConfig
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (ParseException -> Either Text Value)
-> (Value -> Either Text Value)
-> Either ParseException Value
-> Either Text Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text Value
forall a b. a -> Either a b
Left (Text -> Either Text Value)
-> (ParseException -> Text) -> ParseException -> Either Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (ParseException -> String) -> ParseException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> String
forall a. Show a => a -> String
show) Value -> Either Text Value
forall a b. b -> Either a b
Right)
(Either ParseException Value -> Either Text AppConfig)
-> IO (Either ParseException Value) -> IO (Either Text AppConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either ParseException Value)
forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
path
loadAppConfig
:: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)
=> FilePath
-> Resolver
-> LightT env m ()
loadAppConfig :: String -> Resolver -> LightT env m ()
loadAppConfig path :: String
path mapper :: Resolver
mapper = (Maybe () -> ()) -> LightT env m (Maybe ()) -> LightT env m ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> (() -> ()) -> Maybe () -> ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe () () -> ()
forall a. a -> a
id) (LightT env m (Maybe ()) -> LightT env m ())
-> LightT env m (Maybe ()) -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (LightT env m) () -> LightT env m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (LightT env m) () -> LightT env m (Maybe ()))
-> MaybeT (LightT env m) () -> LightT env m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
AppConfig
conf <- String -> MaybeT (LightT env m) (Either Text AppConfig)
forall (m :: * -> *).
MonadIO m =>
String -> m (Either Text AppConfig)
resolveConfig String
path MaybeT (LightT env m) (Either Text AppConfig)
-> (Either Text AppConfig -> MaybeT (LightT env m) AppConfig)
-> MaybeT (LightT env m) AppConfig
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left e :: Text
e -> do
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ Text -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.err Text
e
String -> MaybeT (LightT env m) AppConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ""
Right r :: AppConfig
r -> AppConfig -> MaybeT (LightT env m) AppConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AppConfig
r
Vector (Text, ComponentConfig)
confs <- LightT env m (Vector (Text, ComponentConfig))
-> MaybeT (LightT env m) (Vector (Text, ComponentConfig))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m (Vector (Text, ComponentConfig))
-> MaybeT (LightT env m) (Vector (Text, ComponentConfig)))
-> LightT env m (Vector (Text, ComponentConfig))
-> MaybeT (LightT env m) (Vector (Text, ComponentConfig))
forall a b. (a -> b) -> a -> b
$ (Vector (Maybe (Text, ComponentConfig))
-> Vector (Text, ComponentConfig))
-> LightT env m (Vector (Maybe (Text, ComponentConfig)))
-> LightT env m (Vector (Text, ComponentConfig))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe (Text, ComponentConfig) -> Maybe (Text, ComponentConfig))
-> Vector (Maybe (Text, ComponentConfig))
-> Vector (Text, ComponentConfig)
forall a b. (a -> Maybe b) -> Vector a -> Vector b
V.mapMaybe Maybe (Text, ComponentConfig) -> Maybe (Text, ComponentConfig)
forall a. a -> a
id) (LightT env m (Vector (Maybe (Text, ComponentConfig)))
-> LightT env m (Vector (Text, ComponentConfig)))
-> LightT env m (Vector (Maybe (Text, ComponentConfig)))
-> LightT env m (Vector (Text, ComponentConfig))
forall a b. (a -> b) -> a -> b
$ Vector ComponentConfig
-> (ComponentConfig
-> LightT env m (Maybe (Text, ComponentConfig)))
-> LightT env m (Vector (Maybe (Text, ComponentConfig)))
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM (AppConfig -> Vector ComponentConfig
app AppConfig
conf) ((ComponentConfig -> LightT env m (Maybe (Text, ComponentConfig)))
-> LightT env m (Vector (Maybe (Text, ComponentConfig))))
-> (ComponentConfig
-> LightT env m (Maybe (Text, ComponentConfig)))
-> LightT env m (Vector (Maybe (Text, ComponentConfig)))
forall a b. (a -> b) -> a -> b
$ \conf :: ComponentConfig
conf -> do
Text
uid <- LightT env m Text
forall (m :: * -> *). MonadIO m => m Text
newUID
Either String Component
result <- Resolver
-> Maybe Text
-> ComponentConfig
-> LightT env m (Either String Component)
forall env (m :: * -> *).
(HasLoaderEnv env, HasLightEnv env, MonadIO m) =>
Resolver
-> Maybe Text
-> ComponentConfig
-> LightT env m (Either String Component)
createComponentBy Resolver
mapper (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uid) ComponentConfig
conf
case Either String Component
result of
Left e :: String
e -> do
String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.err String
e
Maybe (Text, ComponentConfig)
-> LightT env m (Maybe (Text, ComponentConfig))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, ComponentConfig)
forall a. Maybe a
Nothing
Right component :: Component
component -> do
Registry Component
reg <- Getting (Registry Component) env (Registry Component)
-> LightT env m (Registry Component)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Registry Component) env (Registry Component)
forall c. HasLoaderEnv c => Lens' c (Registry Component)
_registry
Registry Component -> Text -> Component -> LightT env m ()
forall (reg :: * -> *) (m :: * -> *) v.
(IRegistry reg, MonadIO m) =>
reg v -> Text -> v -> m ()
R.register Registry Component
reg Text
uid Component
component
String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.info
(String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "Component loaded: {type: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (ComponentConfig -> Text
componentType ComponentConfig
conf)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", uid: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
uid
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "}"
Maybe (Text, ComponentConfig)
-> LightT env m (Maybe (Text, ComponentConfig))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, ComponentConfig)
-> LightT env m (Maybe (Text, ComponentConfig)))
-> Maybe (Text, ComponentConfig)
-> LightT env m (Maybe (Text, ComponentConfig))
forall a b. (a -> b) -> a -> b
$ (Text, ComponentConfig) -> Maybe (Text, ComponentConfig)
forall a. a -> Maybe a
Just (Text
uid, ComponentConfig
conf)
IORef AppConfig
ref <- Getting (IORef AppConfig) env (IORef AppConfig)
-> MaybeT (LightT env m) (IORef AppConfig)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef AppConfig) env (IORef AppConfig)
forall c. HasLoaderEnv c => Lens' c (IORef AppConfig)
_appConfig
IO () -> MaybeT (LightT env m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT (LightT env m) ())
-> IO () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ IORef AppConfig -> AppConfig -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef AppConfig
ref (AppConfig -> IO ()) -> AppConfig -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector ComponentConfig -> Vector Text -> AppConfig
AppConfig (((Text, ComponentConfig) -> ComponentConfig)
-> Vector (Text, ComponentConfig) -> Vector ComponentConfig
forall a b. (a -> b) -> Vector a -> Vector b
V.map (Text, ComponentConfig) -> ComponentConfig
forall a b. (a, b) -> b
snd Vector (Text, ComponentConfig)
confs) (((Text, ComponentConfig) -> Text)
-> Vector (Text, ComponentConfig) -> Vector Text
forall a b. (a -> b) -> Vector a -> Vector b
V.map (Text, ComponentConfig) -> Text
forall a b. (a, b) -> a
fst Vector (Text, ComponentConfig)
confs)
patchAppConfig
:: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)
=> FilePath
-> Resolver
-> LightT env m ()
patchAppConfig :: String -> Resolver -> LightT env m ()
patchAppConfig path :: String
path resolver :: Resolver
resolver = (Maybe () -> ()) -> LightT env m (Maybe ()) -> LightT env m ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> (() -> ()) -> Maybe () -> ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe () () -> ()
forall a. a -> a
id) (LightT env m (Maybe ()) -> LightT env m ())
-> LightT env m (Maybe ()) -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (LightT env m) () -> LightT env m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (LightT env m) () -> LightT env m (Maybe ()))
-> MaybeT (LightT env m) () -> LightT env m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
IORef AppConfig
cref <- Getting (IORef AppConfig) env (IORef AppConfig)
-> MaybeT (LightT env m) (IORef AppConfig)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef AppConfig) env (IORef AppConfig)
forall c. HasLoaderEnv c => Lens' c (IORef AppConfig)
_appConfig
AppConfig
appConfig <- IO AppConfig -> MaybeT (LightT env m) AppConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppConfig -> MaybeT (LightT env m) AppConfig)
-> IO AppConfig -> MaybeT (LightT env m) AppConfig
forall a b. (a -> b) -> a -> b
$ IORef AppConfig -> IO AppConfig
forall a. IORef a -> IO a
readIORef IORef AppConfig
cref
AppConfig
conf' <- do
Either Text AppConfig
mconf <- LightT env m (Either Text AppConfig)
-> MaybeT (LightT env m) (Either Text AppConfig)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m (Either Text AppConfig)
-> MaybeT (LightT env m) (Either Text AppConfig))
-> LightT env m (Either Text AppConfig)
-> MaybeT (LightT env m) (Either Text AppConfig)
forall a b. (a -> b) -> a -> b
$ String -> LightT env m (Either Text AppConfig)
forall (m :: * -> *).
MonadIO m =>
String -> m (Either Text AppConfig)
resolveConfig String
path
case Either Text AppConfig
mconf of
Left e :: Text
e -> do
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ Text -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.err Text
e
String -> MaybeT (LightT env m) AppConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ""
Right r :: AppConfig
r -> AppConfig -> MaybeT (LightT env m) AppConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AppConfig
r
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
(LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ [Operation] -> (Operation -> LightT env m ()) -> LightT env m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
( Patch -> [Operation]
Diff.patchOperations
(Patch -> [Operation]) -> Patch -> [Operation]
forall a b. (a -> b) -> a -> b
$ Value -> Value -> Patch
Diff.diff (Vector ComponentConfig -> Value
forall a. ToJSON a => a -> Value
toJSON (Vector ComponentConfig -> Value)
-> Vector ComponentConfig -> Value
forall a b. (a -> b) -> a -> b
$ AppConfig -> Vector ComponentConfig
app AppConfig
appConfig) (Vector ComponentConfig -> Value
forall a. ToJSON a => a -> Value
toJSON (Vector ComponentConfig -> Value)
-> Vector ComponentConfig -> Value
forall a b. (a -> b) -> a -> b
$ AppConfig -> Vector ComponentConfig
app AppConfig
conf')
)
((Operation -> LightT env m ()) -> LightT env m ())
-> (Operation -> LightT env m ()) -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ \op :: Operation
op -> (Maybe () -> ()) -> LightT env m (Maybe ()) -> LightT env m ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> (() -> ()) -> Maybe () -> ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe () () -> ()
forall a. a -> a
id) (LightT env m (Maybe ()) -> LightT env m ())
-> LightT env m (Maybe ()) -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (LightT env m) () -> LightT env m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (LightT env m) () -> LightT env m (Maybe ()))
-> MaybeT (LightT env m) () -> LightT env m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.debug (String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "CMR detected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Operation -> String
forall a. Show a => a -> String
show Operation
op
case Operation
op of
Add (Pointer [AKey n :: Int
n]) v :: Value
v -> Int -> Value -> MaybeT (LightT env m) ()
create Int
n Value
v
Rem (Pointer [AKey n :: Int
n]) -> Int -> MaybeT (LightT env m) ()
forall s (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadReader s (t m), HasLoaderEnv s, MonadTrans t, MonadIO m,
MonadIO (t m), MonadLogger m) =>
Int -> t m ()
remove Int
n
Rep (Pointer [AKey n :: Int
n ]) v :: Value
v -> Int -> Operation -> MaybeT (LightT env m) ()
modify Int
n (Pointer -> Value -> Operation
Rep (Path -> Pointer
Pointer []) Value
v)
Rep (Pointer (AKey n :: Int
n:path :: Path
path)) v :: Value
v -> Int -> Operation -> MaybeT (LightT env m) ()
modify Int
n (Pointer -> Value -> Operation
Rep (Path -> Pointer
Pointer Path
path) Value
v)
Add (Pointer (AKey n :: Int
n:path :: Path
path)) v :: Value
v -> Int -> Operation -> MaybeT (LightT env m) ()
modify Int
n (Pointer -> Value -> Operation
Add (Path -> Pointer
Pointer Path
path) Value
v)
Rem (Pointer (AKey n :: Int
n:path :: Path
path)) -> Int -> Operation -> MaybeT (LightT env m) ()
modify Int
n (Pointer -> Operation
Rem (Path -> Pointer
Pointer Path
path))
_ ->
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
(LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.warn
(String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "CMR does not support the operation yet: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Operation -> String
forall a. Show a => a -> String
show Operation
op
where
create :: Int -> Value -> MaybeT (LightT env m) ()
create n :: Int
n v :: Value
v = do
IORef AppConfig
cref <- Getting (IORef AppConfig) env (IORef AppConfig)
-> MaybeT (LightT env m) (IORef AppConfig)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef AppConfig) env (IORef AppConfig)
forall c. HasLoaderEnv c => Lens' c (IORef AppConfig)
_appConfig
ComponentConfig
compConf <- case Value -> Result ComponentConfig
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Success a :: ComponentConfig
a -> ComponentConfig -> MaybeT (LightT env m) ComponentConfig
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentConfig
a
Error err :: String
err -> do
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.err String
err
String -> MaybeT (LightT env m) ComponentConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ""
Text
newID <- LightT env m Text -> MaybeT (LightT env m) Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift LightT env m Text
forall (m :: * -> *). MonadIO m => m Text
newUID
Component
component <- do
Either String Component
result <- LightT env m (Either String Component)
-> MaybeT (LightT env m) (Either String Component)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m (Either String Component)
-> MaybeT (LightT env m) (Either String Component))
-> LightT env m (Either String Component)
-> MaybeT (LightT env m) (Either String Component)
forall a b. (a -> b) -> a -> b
$ Resolver
-> Maybe Text
-> ComponentConfig
-> LightT env m (Either String Component)
forall env (m :: * -> *).
(HasLoaderEnv env, HasLightEnv env, MonadIO m) =>
Resolver
-> Maybe Text
-> ComponentConfig
-> LightT env m (Either String Component)
createComponentBy Resolver
resolver (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
newID) ComponentConfig
compConf
case Either String Component
result of
Left err :: String
err -> do
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.err (String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "Failed to resolve: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
String -> MaybeT (LightT env m) Component
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ""
Right c :: Component
c -> Component -> MaybeT (LightT env m) Component
forall (m :: * -> *) a. Monad m => a -> m a
return Component
c
Registry Component
reg <- Getting (Registry Component) env (Registry Component)
-> MaybeT (LightT env m) (Registry Component)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Registry Component) env (Registry Component)
forall c. HasLoaderEnv c => Lens' c (Registry Component)
_registry
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ Registry Component -> Int -> Text -> Component -> LightT env m ()
forall (reg :: * -> *) (m :: * -> *) v.
(IRegistry reg, MonadIO m) =>
reg v -> Int -> Text -> v -> m ()
R.insert Registry Component
reg Int
n (Component -> Text
getUID Component
component) Component
component
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
(LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.info
(String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "Component registered: {type: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (ComponentConfig -> Text
componentType ComponentConfig
compConf)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", uid: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (Component -> Text
getUID Component
component)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "}"
IO () -> MaybeT (LightT env m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT (LightT env m) ())
-> IO () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ IORef AppConfig -> (AppConfig -> AppConfig) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AppConfig
cref ((AppConfig -> AppConfig) -> IO ())
-> (AppConfig -> AppConfig) -> IO ()
forall a b. (a -> b) -> a -> b
$ \conf :: AppConfig
conf -> AppConfig
conf
{ app :: Vector ComponentConfig
app = Vector ComponentConfig -> ComponentConfig -> Vector ComponentConfig
forall a. Vector a -> a -> Vector a
V.snoc (AppConfig -> Vector ComponentConfig
app AppConfig
conf) ComponentConfig
compConf
, uuid :: Vector Text
uuid = Vector Text -> Text -> Vector Text
forall a. Vector a -> a -> Vector a
V.snoc (AppConfig -> Vector Text
uuid AppConfig
conf) Text
newID
}
remove :: Int -> t m ()
remove n :: Int
n = do
IORef AppConfig
cref <- Getting (IORef AppConfig) s (IORef AppConfig)
-> t m (IORef AppConfig)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef AppConfig) s (IORef AppConfig)
forall c. HasLoaderEnv c => Lens' c (IORef AppConfig)
_appConfig
AppConfig
appConf <- IO AppConfig -> t m AppConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppConfig -> t m AppConfig) -> IO AppConfig -> t m AppConfig
forall a b. (a -> b) -> a -> b
$ IORef AppConfig -> IO AppConfig
forall a. IORef a -> IO a
readIORef IORef AppConfig
cref
let uid :: Text
uid = AppConfig -> Vector Text
uuid AppConfig
appConf Vector Text -> Int -> Text
forall a. Vector a -> Int -> a
V.! Int
n
Registry Component
reg <- Getting (Registry Component) s (Registry Component)
-> t m (Registry Component)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Registry Component) s (Registry Component)
forall c. HasLoaderEnv c => Lens' c (Registry Component)
_registry
m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> m () -> t m ()
forall a b. (a -> b) -> a -> b
$ Registry Component -> Text -> m ()
forall (reg :: * -> *) (m :: * -> *) v.
(IRegistry reg, MonadIO m) =>
reg v -> Text -> m ()
R.delete Registry Component
reg Text
uid
m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> m () -> t m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.info (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "Component deleted: {uid: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
uid String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "}"
IO () -> t m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> t m ()) -> IO () -> t m ()
forall a b. (a -> b) -> a -> b
$ IORef AppConfig -> AppConfig -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef AppConfig
cref (AppConfig -> IO ()) -> AppConfig -> IO ()
forall a b. (a -> b) -> a -> b
$ AppConfig
appConf
{ app :: Vector ComponentConfig
app = (Int -> ComponentConfig -> Bool)
-> Vector ComponentConfig -> Vector ComponentConfig
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter (\i :: Int
i _ -> Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (Vector ComponentConfig -> Vector ComponentConfig)
-> Vector ComponentConfig -> Vector ComponentConfig
forall a b. (a -> b) -> a -> b
$ AppConfig -> Vector ComponentConfig
app AppConfig
appConf
, uuid :: Vector Text
uuid = (Int -> Text -> Bool) -> Vector Text -> Vector Text
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter (\i :: Int
i _ -> Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (Vector Text -> Vector Text) -> Vector Text -> Vector Text
forall a b. (a -> b) -> a -> b
$ AppConfig -> Vector Text
uuid AppConfig
appConf
}
modify :: Int -> Operation -> MaybeT (LightT env m) ()
modify n :: Int
n op :: Operation
op = do
IORef AppConfig
cref <- Getting (IORef AppConfig) env (IORef AppConfig)
-> MaybeT (LightT env m) (IORef AppConfig)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef AppConfig) env (IORef AppConfig)
forall c. HasLoaderEnv c => Lens' c (IORef AppConfig)
_appConfig
AppConfig
appConf <- IO AppConfig -> MaybeT (LightT env m) AppConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppConfig -> MaybeT (LightT env m) AppConfig)
-> IO AppConfig -> MaybeT (LightT env m) AppConfig
forall a b. (a -> b) -> a -> b
$ IORef AppConfig -> IO AppConfig
forall a. IORef a -> IO a
readIORef IORef AppConfig
cref
ComponentConfig
compConf <-
case Operation -> Value -> Result Value
Diff.applyOperation Operation
op (ComponentConfig -> Value
forall a. ToJSON a => a -> Value
toJSON (AppConfig -> Vector ComponentConfig
app AppConfig
appConf Vector ComponentConfig -> Int -> ComponentConfig
forall a. Vector a -> Int -> a
V.! Int
n)) Result Value
-> (Value -> Result ComponentConfig) -> Result ComponentConfig
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Result ComponentConfig
forall a. FromJSON a => Value -> Result a
fromJSON of
Success a :: ComponentConfig
a -> ComponentConfig -> MaybeT (LightT env m) ComponentConfig
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentConfig
a
Error err :: String
err -> do
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.err String
err
String -> MaybeT (LightT env m) ComponentConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ""
let uid :: Text
uid = AppConfig -> Vector Text
uuid AppConfig
appConf Vector Text -> Int -> Text
forall a. Vector a -> Int -> a
V.! Int
n
Component
component <- do
Either String Component
result <- LightT env m (Either String Component)
-> MaybeT (LightT env m) (Either String Component)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m (Either String Component)
-> MaybeT (LightT env m) (Either String Component))
-> LightT env m (Either String Component)
-> MaybeT (LightT env m) (Either String Component)
forall a b. (a -> b) -> a -> b
$ Resolver
-> Maybe Text
-> ComponentConfig
-> LightT env m (Either String Component)
forall env (m :: * -> *).
(HasLoaderEnv env, HasLightEnv env, MonadIO m) =>
Resolver
-> Maybe Text
-> ComponentConfig
-> LightT env m (Either String Component)
createComponentBy Resolver
resolver (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uid) ComponentConfig
compConf
case Either String Component
result of
Left err :: String
err -> do
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.err (String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "Failed to resolve: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
String -> MaybeT (LightT env m) Component
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ""
Right c :: Component
c -> Component -> MaybeT (LightT env m) Component
forall (m :: * -> *) a. Monad m => a -> m a
return Component
c
Registry Component
reg <- Getting (Registry Component) env (Registry Component)
-> MaybeT (LightT env m) (Registry Component)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Registry Component) env (Registry Component)
forall c. HasLoaderEnv c => Lens' c (Registry Component)
_registry
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ Registry Component -> Text -> Component -> LightT env m ()
forall (reg :: * -> *) (m :: * -> *) v.
(IRegistry reg, MonadIO m) =>
reg v -> Text -> v -> m ()
R.write Registry Component
reg Text
uid Component
component
LightT env m () -> MaybeT (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
(LightT env m () -> MaybeT (LightT env m) ())
-> LightT env m () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ String -> LightT env m ()
forall (m :: * -> *) s.
(MonadLogger m, MonadIO m, ToBuilder s) =>
s -> m ()
Caster.info
(String -> LightT env m ()) -> String -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ "Component replaced: {name: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (ComponentConfig -> Text
componentType ComponentConfig
compConf)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", uid: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (Component -> Text
getUID Component
component)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "}"
IO () -> MaybeT (LightT env m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT (LightT env m) ())
-> IO () -> MaybeT (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ IORef AppConfig -> AppConfig -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef AppConfig
cref (AppConfig -> IO ()) -> AppConfig -> IO ()
forall a b. (a -> b) -> a -> b
$ AppConfig
appConf { app :: Vector ComponentConfig
app = AppConfig -> Vector ComponentConfig
app AppConfig
appConf Vector ComponentConfig
-> [(Int, ComponentConfig)] -> Vector ComponentConfig
forall a. Vector a -> [(Int, a)] -> Vector a
V.// [(Int
n, ComponentConfig
compConf)]
}