@@ -6,22 +6,14 @@
66--frontend modules.
77module Frontend.Utils
88 ( sidebar,
9− buttonClass,
10− buttonClassEnabled,
119 wrapRequestErrors,
1210 octopodTextInput,
1311 deploymentPopupBody,
1412 ClickedElement (..),
1513 pageNotification,
16− aButtonClassEnabled,
17− buttonClassEnabled',
1814 kubeDashboardUrl,
19− loadingCommonWidget,
20− errorCommonWidget,
21− aButtonDynClass',
2215 formatPosixToDate,
2316 overridesWidget,
24− aButtonClass',
2517 statusWidget,
2618 elementClick,
2719 showT,
@@ -29,12 +21,15 @@ module Frontend.Utils
2921 formatPosixToDateTime,
3022 dropdownWidget,
3123 dropdownWidget',
32− buttonDynClass,
3324 deploymentConfigProgressiveComponents,
3425 deploymentConfigProgressive,
3526 holdClearingWith,
3627 unitEv,
37− deploymentSection,
28+ (<&&>),
29+ ProgressiveFullConfig (..),
30+ RequestErrorHandler,
31+ deploymentOverridesWidget,
32+ applicationOverridesWidget,
3833 )
3934where
4035
@@ -42,18 +37,14 @@ import Common.Types as CT
4237import Control.Lens
4338import Control.Monad
4439import Control.Monad.Reader
45−import Data.Align
4640import qualified Data.Foldable as F
4741import Data.Functor
4842import Data.Generics.Labels ()
4943import Data.Generics.Sum
50−import Data.Map (Map)
5144import qualified Data.Map as M
52−import qualified Data.Map.Ordered.Strict as OM
53−import Data.Maybe (fromMaybe)
45+import Data.Maybe (fromMaybe, isNothing)
5446import Data.Monoid
5547import Data.Text as T (Text, intercalate, null, pack)
56−import Data.These
5748import Data.Time
5849import Data.UniqMap
5950import Data.Unique
@@ -61,6 +52,8 @@ import Data.Witherable
6152import Data.WorkingOverrides
6253import Frontend.API
6354import Frontend.GHCJS
55+import Frontend.UIKit
56+import GHC.Generics (Generic)
6457import GHCJS.DOM
6558import GHCJS.DOM.Element as DOM
6659import GHCJS.DOM.EventM (on, target)
@@ -162,148 +155,6 @@ sidebar showEv closeEv m = mdo
162155 ]
163156 pure $ switchDyn $ fst <$> resultEvDyn
164157
165−-- | Dark unclickable background for opened sidebar.
166−popupOverlay :: DomBuilder t m => m ()
167−popupOverlay =
168− elAttr "div" ("class" =: "popup__overlay" <> "aria-hidden" =: "true") blank
169−
170−-- | Button with customizable classes and label text.
171−buttonClass ::
172− (DomBuilder t m, PostBuild t m) =>
173− -- | Classes.
174− Text ->
175− -- | Label text.
176− Text ->
177− m (Event t ())
178−buttonClass cl lbl = do
179− (bEl, _) <-
180− elDynAttr'
181− "button"
182− (constDyn $ "class" =: cl <> "type" =: "button")
183− $ text lbl
184− return $ domEvent Click bEl
185−
186−-- | Advanced version of 'buttonClass' with dynamic arguments.
187−buttonDynClass ::
188− (DomBuilder t m, PostBuild t m) =>
189− -- | Classes.
190− Dynamic t Text ->
191− -- | Label text.
192− Dynamic t Text ->
193− m (Event t ())
194−buttonDynClass clDyn lblDyn = do
195− let attrDyn = ffor clDyn $ \cl -> "class" =: cl <> "type" =: "button"
196− (bEl, _) <-
197− elDynAttr' "button" attrDyn $
198− dynText lblDyn
199− return $ domEvent Click bEl
200−
201−-- | Advanced version of 'buttonClass' with a disabled state.
202−buttonClassEnabled ::
203− (DomBuilder t m, PostBuild t m) =>
204− -- | Classes.
205− Text ->
206− -- | Label text.
207− Text ->
208− -- | Enabled flag.
209− Dynamic t Bool ->
210− m (Event t ())
211−buttonClassEnabled cl lbl dDyn = do
212− let attrDyn = ffor dDyn $ \case
213− True -> "class" =: cl <> "type" =: "button"
214− False ->
215− "class" =: (cl <> " button--disabled")
216− <> "type" =: "button"
217− <> "disabled" =: ""
218− (bEl, _) <-
219− elDynAttr' "button" attrDyn $
220− text lbl
221− return $ domEvent Click bEl
222−
223−-- | Special version of 'buttonClassEnabled' that supports custom classes for
224−-- the disabled state.
225−buttonClassEnabled' ::
226− (DomBuilder t m, PostBuild t m) =>
227− -- | Classes.
228− Text ->
229− -- | Label text.
230− Text ->
231− -- | Enabled flag.
232− Dynamic t Bool ->
233− -- | Custom classes for disabled state.
234− Text ->
235− m (Event t ())
236−buttonClassEnabled' cl lbl dDyn disClass = do
237− let attrDyn = ffor dDyn $ \case
238− True -> "class" =: cl <> "type" =: "button"
239− False ->
240− "class" =: (cl <> " " <> disClass)
241− <> "type" =: "button"
242− <> "disabled" =: ""
243− (bEl, _) <-
244− elDynAttr' "button" attrDyn $
245− text lbl
246− return $ domEvent Click bEl
247−
248−-- | Version of 'buttonClass' for links that should look like buttons.
249−aButtonClass' ::
250− (DomBuilder t m, PostBuild t m) =>
251− -- | Classes.
252− Text ->
253− -- | Label text.
254− Text ->
255− -- | Extra attributes
256− Dynamic t (Map Text Text) ->
257− m (Event t ())
258−aButtonClass' cl lbl eAttrs = do
259− (bEl, _) <-
260− elDynAttr'
261− "a"
262− (fmap (<> ("class" =: cl)) eAttrs)
263− $ text lbl
264− return $ domEvent Click bEl
265−
266−-- | Version of 'buttonDynClass' for links that should look like
267−-- buttons.
268−aButtonDynClass' ::
269− (DomBuilder t m, PostBuild t m) =>
270− -- | Classes.
271− Dynamic t Text ->
272− -- | Label text.
273− Dynamic t Text ->
274− -- | Extra attributes
275− Dynamic t (Map Text Text) ->
276− m (Event t ())
277−aButtonDynClass' clDyn lblDyn eAttrs = do
278− let attrDyn' = ffor clDyn $ \cl -> "class" =: cl
279− attrDyn = (<>) <$> eAttrs <*> attrDyn'
280− (bEl, _) <-
281− elDynAttr' "a" attrDyn $
282− dynText lblDyn
283− return $ domEvent Click bEl
284−
285−-- | Version of 'buttonClassEnabled' for links that should look like
286−-- buttons.
287−aButtonClassEnabled ::
288− (DomBuilder t m, PostBuild t m) =>
289− -- | Classes.
290− Text ->
291− -- | Label text.
292− Text ->
293− -- | Enabled flag.
294− Dynamic t Bool ->
295− m (Event t ())
296−aButtonClassEnabled cl lbl dDyn = do
297− let attrDyn = ffor dDyn $ \case
298− True -> "class" =: cl
299− False ->
300− "class" =: (cl <> " button--disabled")
301− <> "disabled" =: ""
302− (bEl, _) <-
303− elDynAttr' "a" attrDyn $
304− text lbl
305− return $ domEvent Click bEl
306−
307158-- | Formats posix seconds to date in iso8601.
308159formatPosixToDate :: FormatTime t => t -> Text
309160formatPosixToDate = pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing)
@@ -332,7 +183,7 @@ statusWidget stDyn = do
332183octopodTextInput ::
333184 MonadWidget t m =>
334185 -- | Input field classes.
335− Text ->
186+ Classes ->
336187 -- | Label text.
337188 Text ->
338189 -- | Placeholder for input field.
@@ -345,92 +196,9 @@ octopodTextInput ::
345196octopodTextInput clss lbl placeholder val errEv =
346197 elClass "section" "deployment__section" $ do
347198 elClass "h3" "deployment__sub-heading" $ text lbl
348− elClass "div" "deployment__widget" $
349− octopodTextInput' (pure False) clss placeholder (pure . fromMaybe "" $ val) errEv
350−
351−-- | The only text input field that is used in project forms. This input
352−-- provides automatic error message hiding after user starts typing.
353−octopodTextInput' ::
354− MonadWidget t m =>
355− -- | Disabled?
356− Dynamic t Bool ->
357− -- | Input field classes.
358− Text ->
359− -- | Placeholder for input field.
360− Text ->
361− -- | Possible init value.
362− (Dynamic t Text) ->
363− -- | Event carrying the error message.
364− Event t Text ->
365− m (Dynamic t Text, Dynamic t Bool)
366−octopodTextInput' disabledDyn clss placeholder inValDyn' errEv = mdo
367− inValDyn <- holdUniqDyn inValDyn'
368− let inValEv =
369− align (updated inValDyn) (updated valDyn)
370− & fmapMaybe
371− ( \case
372− This x -> Just x
373− These inV currV | inV /= currV -> Just inV
374− _ -> Nothing
375− )
376− let inpClass = " input"
377− inpErrClass = " input input--error"
378− isValid <-
379− holdDyn True $
380− leftmost
381− [ False <$ errEv
382− , True <$ updated valDyn
383− ]
384− classDyn <-
385− holdDyn (clss <> inpClass) $
386− leftmost
387− [ (clss <> inpErrClass) <$ errEv
388− , (clss <> inpClass) <$ updated valDyn
389− ]
390− inVal <- sample . current $ inValDyn
391− disabled <- sample . current $ disabledDyn
392− valDyn <- elDynClass "div" classDyn $ do
393− inp <-
394− inputElement $
395− def
396− & initialAttributes
397− .~ ( "type" =: "text"
398− <> "class" =: "input__widget"
399− <> "placeholder" =: placeholder
400− )
401− & inputElementConfig_setValue .~ inValEv
402− & inputElementConfig_initialValue .~ inVal
403− & inputElementConfig_elementConfig . elementConfig_initialAttributes
404− %~ (if disabled then M.insert "disabled" "disabled" else id)
405− & inputElementConfig_elementConfig . elementConfig_modifyAttributes
406− <>~ updated
407− ( do
408− disabled' <- disabledDyn
409− pure $
410− M.singleton "disabled" $
411− if disabled' then Just "disabled" else Nothing
412− )
413− widgetHold_ blank $
414− leftmost
415− [ divClass "input__output" . text <$> errEv
416− , blank <$ updated valDyn
417− ]
418− pure $ value inp
419− pure (valDyn, isValid)
420−
421−-- | Widget with a loading spinner.
422−loadingCommonWidget :: MonadWidget t m => m ()
423−loadingCommonWidget =
424− divClass "loading loading--enlarged loading--alternate" $
425− text "Loading..."
426−
427−-- | Widget with an error message.
428−errorCommonWidget :: MonadWidget t m => m ()
429−errorCommonWidget =
430− divClass "null null--data" $
431− divClass "null__content" $ do
432− elClass "b" "null__heading" $ text "Cannot retrieve the data"
433− divClass "null__message" $ text "Try to reload the page"
199+ elClass "div" "deployment__widget" $ do
200+ (value -> valDyn, validDyn) <- octopodTextInput' (pure []) (pure False) (pure clss) placeholder (pure . fromMaybe "" $ val) errEv
201+ pure (valDyn, validDyn)
434202
435203-- | Widget that can show and hide overrides if there are more than 3. This
436204-- widget is used in the deployments table and the deployment action table.
@@ -438,51 +206,62 @@ overridesWidget ::
438206 MonadWidget t m =>
439207 -- | List of overrides.
440208 Overrides l ->
209+ (Event t () -> m (Event t (DefaultConfig l))) ->
441210 m ()
442−overridesWidget (Overrides (OM.assocs -> envs)) = divClass "listing listing--for-text" $ do
443− let visible = take 3 envs
444− envLength = length envs
445− listing visible
446− when (envLength > 3) $ mdo
447− let hidden = drop 3 envs
448− showDyn <- toggle False toggleEv
449− dyn_ $
450− showDyn <&> \case
451− True -> listing hidden
452− False -> blank
453− let btnClassDyn =
454− ifThenElseDyn
455− showDyn
456− "listing__more expander expander--open"
457− "listing__more expander"
458− btnTextDyn =
459− ifThenElseDyn showDyn "Hide" $
460− "Show all (" <> showT envLength <> ")"
461− toggleEv <- buttonDynClass btnClassDyn btnTextDyn
462− blank
463− where
464− listing envs' = do
465− forM_ envs' $ \(var, val) ->
466− divClass "listing__item" $ do
467− el "b" $ text $ var <> ": "
468− case val of
469− ValueAdded v -> text v
470− ValueDeleted -> el "i" $ text "<deleted>"
471−
472−-- | @if-then-else@ helper for cases when bool value is wrapped in 'Dynamic'.
473−ifThenElseDyn ::
474− Reflex t =>
475− -- | Condition wrapped in `Dynamic`.
476− Dynamic t Bool ->
477− -- | `then` branch.
478− b ->
479− -- | `else` branch.
480− b ->
481− Dynamic t b
482−ifThenElseDyn bDyn t f =
483− bDyn <&> \case
484− True -> t
485− False -> f
211+overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
212+ defMDyn <- getDef firstExpand >>= holdDynMaybe
213+ dyn_ $
214+ expandState <&> \case
215+ ExpandedState ->
216+ void $
217+ networkView $
218+ do
219+ defM <- defMDyn
220+ pure $
221+ showNonEditableWorkingOverride (isNothing defM) RegularNonEditableWorkingOverrideStyle $
222+ elemsUniq $ constructWorkingOverrides defM ovs
223+ ContractedState ->
224+ let ovsList = elemsUniq $ constructWorkingOverrides Nothing ovs
225+ in showNonEditableWorkingOverride False RegularNonEditableWorkingOverrideStyle $
226+ take 3 ovsList
227+
228+ expandState <-
229+ expanderButton
230+ ExpanderButtonConfig
231+ { buttonText = do
232+ state <- expandState
233+ pure $ case state of
234+ ExpandedState -> "Hide"
235+ ContractedState -> "Show all"
236+ , buttonInitialState = ContractedState
237+ , buttonType = Just ListingExpanderButton
238+ , buttonStyle = RegularExpanderButtonStyle
239+ }
240+ firstExpand <- headE $ ($> ()) $ ffilter (== ExpandedState) $ updated expandState
241+ pure ()
242+
243+deploymentOverridesWidget ::
244+ MonadWidget t m =>
245+ RequestErrorHandler t m ->
246+ Overrides 'DeploymentLevel ->
247+ m ()
248+deploymentOverridesWidget hReq depOvs =
249+ overridesWidget depOvs $ defaultDeploymentOverrides >=> hReq
250+
251+applicationOverridesWidget ::
252+ MonadWidget t m =>
253+ RequestErrorHandler t m ->
254+ Overrides 'DeploymentLevel ->
255+ Overrides 'ApplicationLevel ->
256+ m ()
257+applicationOverridesWidget hReq depOvs appOvs =
258+ overridesWidget appOvs $ \fire -> do
259+ depDefEv <- defaultDeploymentOverrides fire >>= hReq
260+ fmap switchDyn $
261+ networkHold (pure never) $
262+ depDefEv <&> \depDef -> do
263+ pb <- getPostBuild
264+ defaultApplicationOverrides (pure $ Right $ applyOverrides depOvs depDef) pb >>= hReq
486265
487266-- | Type of notification at the top of pages.
488267data DeploymentPageNotification
@@ -506,7 +285,7 @@ pageNotification notEv = mdo
506285 messageClassWidget txt cl =
507286 divClass ("page__output notification " <> cl) $ do
508287 text txt
509− buttonClass "notification__close" ""
288+ closeNotificationButton
510289 closeEv = switchDyn closeEvDyn
511290 closeEvDyn <-
512291 widgetHold (pure never) $
@@ -549,28 +328,25 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
549328
550329 (tagDyn, tOkEv) <- octopodTextInput "tag" "Tag" "Tag" (unDeploymentTag <$> defTag) tagErrEv
551330
552− let holdDCfg :: Dynamic t (Maybe (DefaultConfig l)) -> Overrides l -> m (Dynamic t (Overrides l))
553− holdDCfg dCfgDyn ovs = mdo
331+ let holdDCfg ::
332+ Dynamic t [Text] ->
333+ Dynamic t (Maybe (DefaultConfig l)) ->
334+ Overrides l ->
335+ m (Dynamic t (Overrides l))
336+ holdDCfg values dCfgDyn ovs = mdo
554337 ovsDyn <- holdDyn ovs ovsEv
555338 x <- attachDyn (current ovsDyn) dCfgDyn
556− ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput dCfg ovs') >>= switchHold never >>= debounce 0.5
339+ ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs') >>= switchHold never >>= debounce 0.5
557340 pure ovsDyn
558− holdDKeys n keysDyn = do
559− let loading = loadingCommonWidget
560− deploymentSection n $
561− widgetHold_ loading $
562− keysDyn <&> \case
563− Just keys -> el "ul" $
564− forM_ keys $ \key -> el "li" $ text key
565− Nothing -> loading
566−
567− deploymentOvsDyn <- deploymentSection "Deployment overrides" $ holdDCfg defDep defDepOv
568− holdDKeys "Deployment keys" (Just <$> depKeys)
341+
342+ depKeysDyn <- holdDyn [] depKeys
343+ deploymentOvsDyn <- deploymentSection "Deployment overrides" $ holdDCfg depKeysDyn defDep defDepOv
344+
569345 appKeys <- waitForValuePromptly depCfgEv $ \deploymentCfg -> do
570346 pb' <- getPostBuild
571347 applicationOverrideKeys (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
572− applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg defAppM defAppOv
573− holdDKeys "App keys" appKeys
348+ appKeysDyn <- holdDyn [] $ catMaybes appKeys
349+ applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv
574350
575351 validDyn <- holdDyn True $ updated tOkEv
576352 pure $
@@ -625,23 +401,31 @@ deploymentConfigProgressive ::
625401 RequestErrorHandler t m ->
626402 Dynamic t (Overrides 'DeploymentLevel) ->
627403 Dynamic t (Overrides 'ApplicationLevel) ->
628− m (Event t FullConfig)
404+ m (Dynamic t ProgressiveFullConfig)
629405deploymentConfigProgressive hReq depOvsDyn appOvsDyn = do
630− (_, defAppEv, depCfgEv) <- deploymentConfigProgressiveComponents hReq depOvsDyn
406+ (depCfgEv, defAppEv, _) <- deploymentConfigProgressiveComponents hReq depOvsDyn
631407 defAppMDyn <- holdDynMaybe defAppEv
632− depCfgMDyn <- holdDynMaybe depCfgEv
633− pure . catMaybes . updated $ do
408+ defCfgMDyn <- holdDynMaybe depCfgEv
409+ pure $ do
634410 defAppM <- defAppMDyn
635411 appOvs <- appOvsDyn
636− depCfgM <- depCfgMDyn
637− pure $ do
638− defApp <- defAppM
639− depCfg <- depCfgM
640− pure
641− FullConfig
642− { appConfig = applyOverrides appOvs defApp
643− , depConfig = depCfg
644− }
412+ defDepM <- defCfgMDyn
413+ depOvs <- depOvsDyn
414+ pure
415+ ProgressiveFullConfig
416+ { appConfig = constructWorkingOverrides defAppM appOvs
417+ , appConfigLoading = isNothing defAppM
418+ , depConfig = constructWorkingOverrides defDepM depOvs
419+ , depConfigLoading = isNothing defDepM
420+ }
421+
422+data ProgressiveFullConfig = ProgressiveFullConfig
423+ { appConfig :: WorkingOverrides
424+ , appConfigLoading :: Bool
425+ , depConfig :: WorkingOverrides
426+ , depConfigLoading :: Bool
427+ }
428+ deriving stock (Generic)
645429
646430waitForValuePromptly :: (MonadHold t m, Adjustable t m) => Event t x -> (x -> m (Event t y)) -> m (Event t y)
647431waitForValuePromptly ev f = fmap switchPromptlyDyn $ networkHold (pure never) $ f <$> ev
@@ -682,65 +466,91 @@ errorHeader appErr = do
682466envVarsInput ::
683467 forall l t m.
684468 MonadWidget t m =>
469+ Dynamic t [Text] ->
685470 Maybe (DefaultConfig l) ->
686471 -- | Initial deployment overrides.
687472 Overrides l ->
688473 -- | Updated deployment overrides.
689474 m (Event t (Overrides l))
690−envVarsInput dCfg ovs = mdo
475+envVarsInput values dCfg ovs = mdo
691476 envsDyn <- foldDyn appEndo (constructWorkingOverrides dCfg ovs) $ leftmost [addEv, updEv]
692477 let addEv = clickEv $> Endo (fst . insertUniqStart newWorkingOverride)
693478 clickEv <-
694− buttonClassEnabled'
695− "overrides__add dash dash--add"
696− "Add an override"
697− addingIsEnabled
698− "dash--disabled"
479+ dashButton
480+ DashButtonConfig
481+ { buttonText = "Add an override"
482+ , buttonEnabled = addingIsEnabled
483+ , buttonType = Just AddDashButtonType
484+ , buttonStyle = OverridesDashButtonStyle
485+ }
699486 updEv <-
700487 switchDyn . fmap F.fold
701488 <$> listWithKey
702489 (uniqMap <$> envsDyn)
703− (\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput x)
490+ (\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput values x)
704491 let addingIsEnabled = all (\(WorkingOverrideKey _ x, _) -> not . T.null $ x) . elemsUniq <$> envsDyn
705492 case dCfg of
706493 Just _ -> pure ()
707− Nothing -> loadingCommonWidget
494+ Nothing -> loadingOverrides
708495 pure . updated $ destructWorkingOverrides <$> envsDyn
709496
710−deploymentSection :: DomBuilder t m => Text -> m a -> m a
711−deploymentSection n m = elClass "section" "deployment__section" $ do
712− elClass "h3" "deployment__sub-heading" $ text n
713− elClass "div" "deployment__widget" m
714−
715497-- | Widget for entering a key-value pair. The updated overrides list is
716498-- written to the 'EventWriter'.
717499envVarInput ::
718500 (MonadWidget t m) =>
501+ -- | The key values to suggest to the user
502+ Dynamic t [Text] ->
719503 -- | Current variable key and value.
720504 Dynamic t WorkingOverride ->
721505 m (Event t UserOverrideAction)
722−envVarInput val = do
723− let v =
724− val <&> snd <&> \case
725− WorkingCustomValue x -> x
726− WorkingDefaultValue x -> x
727− WorkingDeletedValue (Just x) -> x
728− WorkingDeletedValue Nothing -> "<loading deleted>"
729− k = val <&> \(WorkingOverrideKey _ x, _) -> x
730− disabledKey = val <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
731−
732− divClass "overrides__item" $ do
733− (keyTextDyn, _) <-
734− octopodTextInput' disabledKey "overrides__key" "key" k never
735− (valTextDyn, _) <-
736− octopodTextInput' (pure False) "overrides__value" "value" v never
737− closeEv <- buttonClass "overrides__delete spot spot--cancel" "Delete"
738− pure $
739− leftmost
740− [ UpdateKey <$> updated keyTextDyn
741− , UpdateValue <$> updated valTextDyn
742− , closeEv $> DeleteOverride
743− ]
506+envVarInput values val = do
507+ let kDyn = val <&> \(WorkingOverrideKey _ x, _) -> x
508+ -- Either <override present> <override deleted>
509+ d <-
510+ eitherDyn $
511+ val <&> snd <&> \case
512+ WorkingCustomValue v -> Right (v, EditedOverrideFieldType)
513+ WorkingDefaultValue v -> Right (v, DefaultOverrideFieldType)
514+ WorkingDeletedValue v -> Left v
515+ networkView >=> switchHold never $
516+ d <&> \case
517+ Right vtDyn -> do
518+ let (vDyn, vTypeDyn) = splitDynPure vtDyn
519+ (keyTextDyn, valTextDyn, closeEv) <-
520+ overrideField
521+ values
522+ OverrideField
523+ { fieldValue = kDyn
524+ , fieldError = never
525+ , fieldDisabled =
526+ val <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
527+ , fieldType =
528+ val <&> \(WorkingOverrideKey t _, _) -> case t of
529+ CustomWorkingOverrideKey -> EditedOverrideFieldType
530+ DefaultWorkingOverrideKey -> DefaultOverrideFieldType
531+ }
532+ OverrideField
533+ { fieldValue = vDyn
534+ , fieldError = never
535+ , fieldDisabled = pure False
536+ , fieldType = vTypeDyn
537+ }
538+ pure $
539+ leftmost
540+ [ UpdateKey <$> updated keyTextDyn
541+ , UpdateValue <$> updated valTextDyn
542+ , closeEv $> DeleteOverride
543+ ]
544+ Left vDyn -> do
545+ restoreEv <-
546+ networkView >=> switchHold never $ do
547+ v <- vDyn
548+ k <- kDyn
549+ pure $ deletedOverride k v
550+ pure $
551+ flip push restoreEv $ \() -> do
552+ v <- sample . current $ vDyn
553+ pure $ UpdateValue <$> v
744554
745555data UserOverrideAction = UpdateKey !Text | UpdateValue !Text | DeleteOverride
746556
@@ -790,3 +600,6 @@ holdClearingWith aEv clear =
790600
791601unitEv :: Reflex t => Dynamic t a -> Event t ()
792602unitEv = fmapCheap (const ()) . updated
603+
604+(<&&>) :: (Functor f1, Functor f2) => f1 (f2 a) -> (a -> b) -> f1 (f2 b)
605+x <&&> f = (fmap . fmap) f x