@@ -42,17 +42,23 @@ import Control.Lens
4242import Control.Monad
4343import Control.Monad.Reader
4444import Control.Monad.State.Strict
45+import qualified Data.Bifunctor as Bi
4546import qualified Data.Foldable as F
4647import Data.Functor
48+import Data.Functor.Misc
4749import Data.Generics.Labels ()
4850import Data.List.NonEmpty (NonEmpty)
51+import Data.Map (Map)
4952import qualified Data.Map as M
5053import Data.Map.Monoidal.Strict (MonoidalMap)
5154import qualified Data.Map.Monoidal.Strict as MM
5255import Data.Maybe (fromMaybe, isJust, isNothing)
5356import Data.Monoid
57+import Data.Set (Set)
58+import qualified Data.Set as S
5459import Data.Text as T (Text, null, pack)
5560import Data.Text.Search
61+import Data.These
5662import Data.Time
5763import Data.UniqMap
5864import Data.Unique
@@ -362,10 +368,13 @@ deploymentPopupBody hReq defAppOv defDepOv errEv = mdo
362368 ovsDyn <- holdDyn ovs ovsEv
363369 ovsDynDebounced <- holdDyn ovs ovsEvDebounced
364370 x <- attachDyn (current ovsDyn) dCfgDyn
365− res <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs')
366− ovsEv <- switchHold never (fst <$> res)
371+ (splitE -> (ovsEvEv, isValidDynEv)) <-
372+ (>>= joinEvM) $
373+ runWithReplace' loadingOverrides $
374+ updated x <&> \(ovs', dCfg) -> untilReady' loadingOverrides $ envVarsInput values dCfg ovs'
375+ ovsEv <- joinEvM ovsEvEv
367376 ovsEvDebounced <- debounce 2 ovsEv
368− isValid <- join <$> holdDyn (pure True) (snd <$> res)
377+ isValid <- join <$> holdDyn (pure False) isValidDynEv
369378 pure (ovsDyn, ovsDynDebounced, isValid)
370379
371380 depKeysDyn <- holdDyn [] depKeys
@@ -494,8 +503,16 @@ envVarsInput ::
494503 -- | Updated deployment overrides.
495504 m (Event t (Overrides l), Dynamic t Bool)
496505envVarsInput values dCfg ovs = mdo
497− envsDyn <- foldDyn appEndo (constructWorkingOverrides dCfg ovs) $ leftmost [addEv, updEv]
498− let addEv = clickEv $> Endo (fst . insertUniqStart newWorkingOverride)
506+ let initialOverrides = constructWorkingOverrides dCfg ovs
507+ (envsDyn, addedKeys) <-
508+ mapAccumDyn
509+ ( \prevOvs -> \case
510+ Left () ->
511+ Bi.second S.singleton $ insertUniqStart newWorkingOverride prevOvs
512+ Right (Endo f) -> (f prevOvs, S.empty)
513+ )
514+ initialOverrides
515+ $ leftmost [Left <$> clickEv, Right <$> updEv]
499516 clickEv <-
500517 dashButton
501518 DashButtonConfig
@@ -505,18 +522,58 @@ envVarsInput values dCfg ovs = mdo
505522 , buttonStyle = OverridesDashButtonStyle
506523 }
507524 let workingOverridesWithErrors = validateWorkingOverrides . uniqMap <$> envsDyn
508− isValid = all ((== mempty) . snd) <$> workingOverridesWithErrors
509− updEv <-
525+ erroredOverride = M.filter ((/= mempty) . snd) <$> workingOverridesWithErrors
526+ isValid = M.null <$> erroredOverride
527+ (_, changedValues) <-
528+ mapAccumDyn
529+ ( \prev new ->
530+ ( fmap (\(v, _) -> (v, mempty)) new
531+ , new <> prev
532+ )
533+ )
534+ mempty
535+ (updated erroredOverride)
536+ let updatedValues = restrictMapEv updatedKeys (updated workingOverridesWithErrors)
537+ valChangedEvSelector = fanMap (clearedOvs <> changedValues <> updatedValues)
538+ (splitE -> (clearedOvs, deletedOvs)) =
539+ alignEventWithMaybe
540+ ( \case
541+ These keys m ->
542+ Just $
543+ let cleared = M.restrictKeys m keys
544+ in (cleared, M.fromSet (const Nothing) (keys `S.difference` M.keysSet cleared))
545+ _ -> Nothing
546+ )
547+ removedKeys
548+ (updated workingOverridesWithErrors)
549+ listChange =
550+ deletedOvs <> (fmap . fmap) Just (restrictMapEv addedKeys (updated workingOverridesWithErrors))
551+
552+ (splitE3 -> (updEv, removedKeys, updatedKeys)) <-
510553 switchDyn . fmap F.fold
511− <$> listWithKey
512− workingOverridesWithErrors
513− (\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput values x)
554+ <$> listHoldWithKey
555+ (validateWorkingOverrides . uniqMap $ initialOverrides)
556+ listChange
557+ ( \i val -> do
558+ valDyn <- holdDyn val $ select valChangedEvSelector $ Const2 i
559+ userActionEv <- envVarInput values valDyn
560+ pure $ performUserOverrideAction (lookupDefaultConfig <$> dCfg) i <$> userActionEv
561+ )
514562 let addingIsEnabled = all (\(WorkingOverrideKey _ x, _) -> not . T.null $ x) . elemsUniq <$> envsDyn
515563 case dCfg of
516564 Just _ -> pure ()
517565 Nothing -> loadingOverrides
518566 pure (updated $ destructWorkingOverrides <$> envsDyn, isValid)
519567
568+restrictMapEv :: (Reflex t, Ord k) => Event t (Set k) -> Event t (Map k v) -> Event t (Map k v)
569+restrictMapEv =
570+ alignEventWithMaybe
571+ ( \case
572+ These keys _ | S.null keys -> Nothing
573+ These keys m -> Just $ M.restrictKeys m keys
574+ _ -> Nothing
575+ )
576+
520577validateWorkingOverrides ::
521578 forall f.
522579 Traversable f =>
@@ -567,7 +624,7 @@ envVarInput ::
567624 -- | Current variable key and value.
568625 Dynamic t (WorkingOverride, OverrideErrors) ->
569626 m (Event t UserOverrideAction)
570−envVarInput values val = do
627+envVarInput values val = untilReadyEv' loadingOverride $ do
571628 let kDyn = val <&> fst <&> \(WorkingOverrideKey _ x, _) -> x
572629 -- Either <override present> <override deleted>
573630 d <-
@@ -622,25 +679,29 @@ performUserOverrideAction ::
622679 Maybe (Text -> Maybe Text) ->
623680 Int ->
624681 UserOverrideAction ->
625− Endo WorkingOverrides
626−performUserOverrideAction f i (UpdateValue v) = Endo $
627− updateUniq i $ \(k@(WorkingOverrideKey _ kt), _) ->
628− ( k
629− , case f >>= ($ kt) of
630− Just v' | v == v' -> WorkingDefaultValue v
631− _ -> WorkingCustomValue v
632− )
633−performUserOverrideAction _ i (UpdateKey k) = Endo $
634− updateUniq i $
635− \(_, v) -> (WorkingOverrideKey CustomWorkingOverrideKey k, v)
636−performUserOverrideAction f i DeleteOverride = Endo $ \m ->
637− case f of
638− Nothing -> updateUniq i (\(k, _) -> (k, WorkingDeletedValue Nothing)) m
639− Just _ -> case lookupUniq i m of
640− Nothing -> m
641− Just (WorkingOverrideKey DefaultWorkingOverrideKey k, _) ->
642− updateUniq i (const (WorkingOverrideKey DefaultWorkingOverrideKey k, WorkingDeletedValue (f >>= ($ k)))) m
643− Just (WorkingOverrideKey CustomWorkingOverrideKey _, _) -> deleteUniq i m
682+ -- | (endo, removed/cleared keys, updatedKeys)
683+ (Endo WorkingOverrides, Set Int, Set Int)
684+performUserOverrideAction f i (UpdateValue v) = (,S.empty,S.singleton i) $
685+ Endo $
686+ updateUniq i $ \(k@(WorkingOverrideKey _ kt), _) ->
687+ ( k
688+ , case f >>= ($ kt) of
689+ Just v' | v == v' -> WorkingDefaultValue v
690+ _ -> WorkingCustomValue v
691+ )
692+performUserOverrideAction _ i (UpdateKey k) = (,S.empty,S.singleton i) $
693+ Endo $
694+ updateUniq i $
695+ \(_, v) -> (WorkingOverrideKey CustomWorkingOverrideKey k, v)
696+performUserOverrideAction f i DeleteOverride = (,S.singleton i,S.empty) $
697+ Endo $ \m ->
698+ case f of
699+ Nothing -> updateUniq i (\(k, _) -> (k, WorkingDeletedValue Nothing)) m
700+ Just _ -> case lookupUniq i m of
701+ Nothing -> m
702+ Just (WorkingOverrideKey DefaultWorkingOverrideKey k, _) ->
703+ updateUniq i (const (WorkingOverrideKey DefaultWorkingOverrideKey k, WorkingDeletedValue (f >>= ($ k)))) m
704+ Just (WorkingOverrideKey CustomWorkingOverrideKey _, _) -> deleteUniq i m
644705
645706holdDynMaybe :: (Reflex t, MonadHold t m) => Event t a -> m (Dynamic t (Maybe a))
646707holdDynMaybe ev = holdDyn Nothing $ fmapCheap Just ev
@@ -685,3 +746,6 @@ catchReturns :: (DomBuilder t m, MonadFix m) => (Event t () -> m a) -> m a
685746catchReturns f = mdo
686747 (divEl, a) <- el' "div" $ f $ ($> ()) . ffilter (== 13) $ domEvent Keypress divEl
687748 pure a
749+
750+splitE3 :: Reflex t => Event t (a, b, c) -> (Event t a, Event t b, Event t c)
751+splitE3 e = ((\(a, _, _) -> a) <$> e, (\(_, b, _) -> b) <$> e, (\(_, _, c) -> c) <$> e)