@@ -20,60 +20,45 @@ module Frontend.Utils
2020 DeploymentPageNotification (..),
2121 formatPosixToDateTime,
2222 dropdownWidget,
23− dropdownWidget',
2423 deploymentConfigProgressiveComponents,
25− deploymentConfigProgressive,
24+ -- deploymentConfigProgressive,
2625 holdClearingWith,
2726 unitEv,
2827 (<&&>),
29− ProgressiveFullConfig (..),
3028 RequestErrorHandler,
31− deploymentOverridesWidget,
32− deploymentOverridesWidgetSearched,
33− applicationOverridesWidget,
34− applicationOverridesWidgetSearched,
3529 debounceDyn,
3630 catchReturns,
31+ holdDynMaybe,
32+ constructWorkingOverridesEv,
3733 )
3834where
3935
4036import Common.Types as CT
37+import Control.Arrow
4138import Control.Lens
4239import Control.Monad
4340import Control.Monad.Reader
44−import Control.Monad.State.Strict
45−import qualified Data.Bifunctor as Bi
46−import qualified Data.Foldable as F
41+import qualified Data.ConfigTree as CT
4742import Data.Functor
48−import Data.Functor.Misc
4943import Data.Generics.Labels ()
50−import Data.List.NonEmpty (NonEmpty)
51−import Data.Map (Map)
44+import Data.Generics.Sum
5245import qualified Data.Map as M
53−import Data.Map.Monoidal.Strict (MonoidalMap)
54−import qualified Data.Map.Monoidal.Strict as MM
55−import Data.Maybe (fromMaybe, isJust, isNothing)
56−import Data.Monoid
57−import Data.Set (Set)
58−import qualified Data.Set as S
46+import Data.Maybe (fromMaybe)
47+import Data.String
5948import Data.Text as T (Text, null, pack, strip)
60−import Data.Text.Search
61−import Data.These
6249import Data.Time
6350import Data.UniqMap
6451import Data.Unique
6552import Data.Witherable
6653import Data.WorkingOverrides
54+import Debug.Trace
6755import Frontend.API
6856import Frontend.GHCJS
6957import Frontend.UIKit
70−import GHC.Generics (Generic)
7158import GHCJS.DOM
7259import GHCJS.DOM.Element as DOM
7360import GHCJS.DOM.EventM (on, target)
7461import GHCJS.DOM.GlobalEventHandlers as Events (click)
75−import GHCJS.DOM.Node as DOM
76−import Generic.Data (Generically (..))
7762import Reflex.Dom as R
7863import Reflex.Dom.Renderable
7964import Reflex.Network
@@ -90,49 +75,30 @@ elementClick = do
9075 doc <- currentDocumentUnchecked
9176 wrapDomEvent doc (`on` Events.click) $ ClickedElement <$> target
9277
93−-- | Dropdown widget which binds its own @document click@ event.
94−dropdownWidget ::
95− MonadWidget t m =>
96− -- | Button widget which opens the dropdown widget.
97− m () ->
98− -- | Widget with the dropdown list.
99− -- Returns an event carrying the user's selection.
100− m (Event t a) ->
101− m (Event t a)
102−dropdownWidget btn body = mdo
103− clickedEl <- elementClick
104− dropdownWidget' clickedEl btn body
105−
10678-- | Similar to 'dropdownWidget' but uses @document click@ event that may be
10779-- shared between other widgets.
108−dropdownWidget' ::
80+dropdownWidget ::
10981 MonadWidget t m =>
110− -- | Document click event that may be shared between other widgets.
111− Event t ClickedElement ->
112− -- | Button widget which opens the dropdown widget.
113− m () ->
11482 -- | Widget with the dropdown list.
11583 -- Returns an event carrying the user's selection.
11684 m (Event t a) ->
11785 m (Event t a)
118−dropdownWidget' clickedEl btn body = mdo
119− clickInsideEv <- performEvent $
120− ffor clickedEl $ \(ClickedElement clicked) ->
121− DOM.contains (_element_raw btnEl) clicked
122− openedDyn <- foldDyn switchState False $ clickInsideEv
123− let switchState ev cur = ev && not cur
124− wrapperClassDyn = ffor openedDyn $ \case
86+dropdownWidget body = mdo
87+ openedDyn <- toggle False $ btnEl
88+ let wrapperClassDyn = ffor openedDyn $ \case
12589 True -> "class" =: "drop drop--actions drop--expanded"
12690 False -> "class" =: "drop drop--actions"
127− (btnEl, (_, wEv)) <- elDynAttr'
91+ (btnEl, wEv) <- elDynAttr
12892 "div"
12993 wrapperClassDyn
13094 $ do
131− btn
132− elDynAttr'
133− "div"
134− (constDyn $ "class" =: "drop__dropdown")
135− body
95+ clickedEv <- dropButton
96+ aEv <-
97+ elDynAttr
98+ "div"
99+ (constDyn $ "class" =: "drop__dropdown")
100+ body
101+ pure (clickedEv, aEv)
136102 pure wEv
137103
138104showT :: Show a => a -> Text
@@ -214,90 +180,46 @@ octopodTextInput clss lbl placeholder val errEv =
214180 elClass "section" "deployment__section" $ do
215181 elClass "h3" "deployment__sub-heading" $ text lbl
216182 elClass "div" "deployment__widget" $ do
217− (value -> valDyn, validDyn) <- octopodTextInput' (pure []) (pure False) (pure clss) placeholder (pure . fromMaybe "" $ val) errEv
183+ (value -> valDyn, validDyn) <- octopodTextInput' (pure []) (pure False) (pure mempty) (pure clss) placeholder (pure . fromMaybe "" $ val) errEv
218184 pure (valDyn, validDyn)
219185
220186-- | Widget that can show and hide overrides if there are more than 3. This
221187-- widget is used in the deployments table and the deployment action table.
222188overridesWidget ::
223− (MonadWidget t m, Renderable te, Ord te) =>
189+ (MonadWidget t m, Renderable te, IsString te, Monoid te) =>
224190 -- | List of overrides.
225191 Overrides' te l ->
226− (Event t () -> m (Event t (DefaultConfig' te l))) ->
227192 m ()
228−overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
229− defMDyn <- getDef firstExpand >>= holdDynMaybe
230− dyn_ $
231− expandState <&> \case
232− ExpandedState ->
233− void $
234− networkView $
235− do
236− defM <- defMDyn
237− pure $
238− showNonEditableWorkingOverride (isNothing defM) (isJust defM) RegularNonEditableWorkingOverrideStyle $
239− elemsUniq $ constructWorkingOverrides defM ovs
240− ContractedState ->
241− let ovsList = elemsUniq $ constructWorkingOverrides Nothing ovs
242− in showNonEditableWorkingOverride False False RegularNonEditableWorkingOverrideStyle $
243− take 3 ovsList
244−
245− expandState <-
246− expanderButton
247− ExpanderButtonConfig
248− { buttonText = do
249− s <- expandState
250− pure $ case s of
251− ExpandedState -> "Hide default configuration"
252− ContractedState -> "Show full configuration"
253− , buttonInitialState = ContractedState
254− , buttonType = Just ListingExpanderButton
255− , buttonStyle = RegularExpanderButtonStyle
256− }
257− firstExpand <- headE $ ($> ()) $ ffilter (== ExpandedState) $ updated expandState
193+overridesWidget (Overrides ovs) = mdo
194+ let l = CT.toFlatList ovs
195+ expandable = length l > 3
196+
197+ if expandable
198+ then mdo
199+ dyn_ $
200+ expandState <&> \s -> do
201+ let l' = case s of
202+ ExpandedState -> l
203+ ContractedState -> take 3 l
204+ showFlatConfig l'
205+ pure ()
206+
207+ expandState <-
208+ expanderButton
209+ ExpanderButtonConfig
210+ { buttonText = do
211+ s <- expandState
212+ pure $ case s of
213+ ExpandedState -> "Hide default configuration"
214+ ContractedState -> "Show full configuration"
215+ , buttonInitialState = ContractedState
216+ , buttonType = Just ListingExpanderButton
217+ , buttonStyle = RegularExpanderButtonStyle
218+ }
219+ pure ()
220+ else showFlatConfig l
258221 pure ()
259222
260−deploymentOverridesWidget ::
261− (MonadWidget t m) =>
262− RequestErrorHandler t m ->
263− Overrides 'DeploymentLevel ->
264− m ()
265−deploymentOverridesWidget hReq depOvs =
266− deploymentOverridesWidgetSearched hReq (wrapResult depOvs)
267−
268−deploymentOverridesWidgetSearched ::
269− (MonadWidget t m) =>
270− RequestErrorHandler t m ->
271− Overrides' SearchResult 'DeploymentLevel ->
272− m ()
273−deploymentOverridesWidgetSearched hReq depOvs =
274− overridesWidget depOvs $ (fmap . fmap . fmap) wrapResult $ defaultDeploymentOverrides >=> hReq
275−
276−applicationOverridesWidget ::
277− MonadWidget t m =>
278− RequestErrorHandler t m ->
279− Overrides 'DeploymentLevel ->
280− Overrides 'ApplicationLevel ->
281− m ()
282−applicationOverridesWidget hReq depOvs appOvs =
283− applicationOverridesWidgetSearched hReq (wrapResult depOvs) (wrapResult appOvs)
284−
285−applicationOverridesWidgetSearched ::
286− MonadWidget t m =>
287− RequestErrorHandler t m ->
288− Overrides' SearchResult 'DeploymentLevel ->
289− Overrides' SearchResult 'ApplicationLevel ->
290− m ()
291−applicationOverridesWidgetSearched hReq depOvs appOvs =
292− overridesWidget appOvs $ \fire -> do
293− depDefEv <- defaultDeploymentOverrides fire >>= hReq
294− fmap switchDyn $
295− (fmap . fmap . fmap) wrapResult $
296− networkHold (pure never) $
297− depDefEv <&> \depDef -> do
298− pb <- getPostBuild
299− defaultApplicationOverrides (pure $ Right $ applyOverrides (deSearch depOvs) depDef) pb >>= hReq
300−
301223-- | Type of notification at the top of pages.
302224data DeploymentPageNotification
303225 = -- | Message text for a \"success\" events.
@@ -351,9 +273,11 @@ deploymentPopupBody ::
351273 m (Dynamic t (Maybe DeploymentUpdate))
352274deploymentPopupBody hReq defAppOv defDepOv errEv = mdo
353275 pb <- getPostBuild
354− (defDepEv, defApp, depCfgEv) <- deploymentConfigProgressiveComponents hReq deploymentOvsDynDebounced
355− defAppM <- holdClearingWith defApp (unitEv deploymentOvsDyn)
356− defDep <- holdDynMaybe defDepEv
276+ (defDepEv, defAppEv, depCfgEv) <-
277+ deploymentConfigProgressiveComponents hReq deploymentOvsDynDebounced
278+
279+ defAppEvM <- holdClearingWith defAppEv (unitEv deploymentOvsDyn)
280+
357281 depKeys <- deploymentOverrideKeys pb >>= hReq
358282
359283 let commandResponseEv = fmapMaybe commandResponse errEv
@@ -361,46 +285,47 @@ deploymentPopupBody hReq defAppOv defDepOv errEv = mdo
361285
362286 let holdDCfg ::
363287 Dynamic t [Text] ->
364− Dynamic t (Maybe (DefaultConfig l)) ->
288+ (DefaultConfig l) ->
365289 Overrides l ->
366− m (Dynamic t (Overrides l), Dynamic t (Overrides l), Dynamic t Bool)
367− holdDCfg values dCfgDyn ovs = mdo
368− ovsDyn <- holdDyn ovs ovsEv
369− ovsDynDebounced <- holdDyn ovs ovsEvDebounced
370− x <- attachDyn (current ovsDyn) dCfgDyn
371− (splitE -> (ovsEvEv, isValidDynEv)) <-
372− (>>= joinEvM) $
373− runWithReplace' loadingOverrides $
374− updated x <&> \(ovs', dCfg) -> untilReady' loadingOverrides $ envVarsInput values dCfg ovs'
375− ovsEv <- joinEvM ovsEvEv
376− ovsEvDebounced <- debounce 2 ovsEv
377− isValid <- join <$> holdDyn (pure False) isValidDynEv
378− pure (ovsDyn, ovsDynDebounced, isValid)
290+ m (Dynamic t (Overrides l), Dynamic t (Overrides l))
291+ holdDCfg (traceDyn "values" -> values) cfgDyn@(DefaultConfig ct) ovs = mdo
292+ let ovs' = constructWorkingOverrides cfgDyn ovs
293+ lookupOverride k = CT.lookup (CT.deconstructConfigKey k) ct
294+ (resCfgDyn :: Dynamic t [Dynamic t WorkingOverride]) <- envVarsInput values lookupOverride ovs'
295+ (resEvDebounced :: Event t [Dynamic t WorkingOverride]) <- debounce 2 $ updated resCfgDyn
296+ let resDyn' = join . fmap destructWorkingOverridesDyn $ resCfgDyn
297+ debouncedResDyn <- fmap join . holdDyn (pure ovs) . fmap destructWorkingOverridesDyn $ resEvDebounced
298+ pure (resDyn', debouncedResDyn)
379299
380300 depKeysDyn <- holdDyn [] depKeys
381− (deploymentOvsDyn, deploymentOvsDynDebounced, depValidDyn) <-
382− deploymentSection "Deployment configuration" $ holdDCfg depKeysDyn defDep defDepOv
301+
302+ (join . fmap fst &&& join . fmap snd -> (deploymentOvsDyn, deploymentOvsDynDebounced)) <-
303+ deploymentSection "Deployment configuration" $
304+ networkHold (loadingOverrides $> (pure defDepOv, pure defDepOv)) $
305+ defDepEv <&> \defDep -> holdDCfg depKeysDyn defDep defDepOv
383306
384307 appKeys <- waitForValuePromptly depCfgEv $ \deploymentCfg -> do
385308 pb' <- getPostBuild
386309 applicationOverrideKeys (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
310+
387311 appKeysDyn <- holdDyn [] $ catMaybes appKeys
388− (applicationOvsDyn, _, appValidDyn) <- deploymentSection "App configuration" $ holdDCfg appKeysDyn defAppM defAppOv
312+ (join -> applicationOvsMDyn) <-
313+ deploymentSection "App configuration" >=> holdDyn (pure Nothing) . fmap sequenceA $
314+ networkView $
315+ defAppEvM <&> \case
316+ Nothing -> loadingOverrides $> Nothing
317+ Just defApp -> Just . fst <$> holdDCfg appKeysDyn defApp defAppOv
389318
390319 pure $ do
391− depValid <- depValidDyn
392− appValid <- appValidDyn
393− if depValid && appValid
394− then do
395− depCfg <- deploymentOvsDyn
396− appOvs <- applicationOvsDyn
397− pure $
398− Just $
399− DeploymentUpdate
400− { appOverrides = appOvs
401− , deploymentOverrides = depCfg
402− }
403− else pure Nothing
320+ depCfg <- deploymentOvsDyn
321+ appOvsM <- applicationOvsMDyn
322+ pure $ do
323+ appOvs <- appOvsM
324+ Just $
325+ DeploymentUpdate
326+ { appOverrides = appOvs
327+ , deploymentOverrides = depCfg
328+ }
404329
405330deploymentConfigProgressiveComponents ::
406331 MonadWidget t m =>
@@ -427,36 +352,17 @@ deploymentConfigProgressiveComponents hReq depOvsDyn = do
427352 defaultApplicationOverrides (pure $ Right depCfg) pb' >>= hReq
428353 pure (defDepEv, defAppEv, depCfgEv)
429354
430−deploymentConfigProgressive ::
431− MonadWidget t m =>
432− RequestErrorHandler t m ->
433− Dynamic t (Overrides 'DeploymentLevel) ->
434− Dynamic t (Overrides 'ApplicationLevel) ->
435− m (Dynamic t ProgressiveFullConfig)
436−deploymentConfigProgressive hReq depOvsDyn appOvsDyn = do
437− (depCfgEv, defAppEv, _) <- deploymentConfigProgressiveComponents hReq depOvsDyn
438− defAppMDyn <- holdDynMaybe defAppEv
439− defCfgMDyn <- holdDynMaybe depCfgEv
440− pure $ do
441− defAppM <- defAppMDyn
442− appOvs <- appOvsDyn
443− defDepM <- defCfgMDyn
444− depOvs <- depOvsDyn
445− pure
446− ProgressiveFullConfig
447− { appConfig = constructWorkingOverrides defAppM appOvs
448− , appConfigLoading = isNothing defAppM
449− , depConfig = constructWorkingOverrides defDepM depOvs
450− , depConfigLoading = isNothing defDepM
451− }
452−
453−data ProgressiveFullConfig = ProgressiveFullConfig
454− { appConfig :: WorkingOverrides
455− , appConfigLoading :: Bool
456− , depConfig :: WorkingOverrides
457− , depConfigLoading :: Bool
458− }
459− deriving stock (Generic)
355+constructWorkingOverridesEv ::
356+ MonadWidget t m => Event t (DefaultConfig l) -> Dynamic t (Overrides l) -> m (Event t WorkingOverrides)
357+constructWorkingOverridesEv defCfgEv ovsDyn = do
358+ defCfgMDyn <- holdDynMaybe defCfgEv
359+ pure $
360+ catMaybes . updated $ do
361+ defCfgM <- defCfgMDyn
362+ ovs <- ovsDyn
363+ pure $ do
364+ defCfg <- defCfgM
365+ pure $ constructWorkingOverrides defCfg ovs
460366
461367waitForValuePromptly :: (MonadHold t m, Adjustable t m) => Event t x -> (x -> m (Event t y)) -> m (Event t y)
462368waitForValuePromptly ev f = fmap switchPromptlyDyn $ networkHold (pure never) $ f <$> ev
@@ -492,32 +398,23 @@ errorHeader ::
492398 -- | Message text.
493399 Dynamic t Text ->
494400 m ()
495−errorHeader appErr = do
496− divClass "deployment__output notification notification--danger" $ do
401+errorHeader appErr =
402+ elClass "pre" "deployment__output notification notification--danger" $
497403 dynText appErr
498404
499405-- | Widget with override fields. This widget supports adding and
500406-- removing key-value pairs.
501407envVarsInput ::
502− forall l t m.
408+ forall t m.
503409 MonadWidget t m =>
504410 Dynamic t [Text] ->
505− Maybe (DefaultConfig l) ->
411+ (Text -> Maybe Text) ->
506412 -- | Initial deployment overrides.
507− Overrides l ->
508− -- | Updated deployment overrides.
509− m (Event t (Overrides l), Dynamic t Bool)
510−envVarsInput values dCfg ovs = mdo
511− let initialOverrides = constructWorkingOverrides dCfg ovs
512− (envsDyn, addedKeys) <-
513− mapAccumDyn
514− ( \prevOvs -> \case
515− Left () ->
516− Bi.second S.singleton $ insertUniqStart newWorkingOverride prevOvs
517− Right (Endo f) -> (f prevOvs, S.empty)
518− )
519− initialOverrides
520− $ leftmost [Left <$> clickEv, Right <$> updEv]
413+ WorkingOverrides ->
414+ -- | Updated deployment overrides. [(<full deconstructed key>, <value>)]
415+ m (Dynamic t [Dynamic t WorkingOverride])
416+envVarsInput (traceDyn "values" -> values) lookupOverride ovs = divClass "padded" $ mdo
417+ let initialConfig = CT.markValues ovs
521418 clickEv <-
522419 dashButton
523420 DashButtonConfig
@@ -526,187 +423,65 @@ envVarsInput values dCfg ovs = mdo
526423 , buttonType = Just AddDashButtonType
527424 , buttonStyle = OverridesDashButtonStyle
528425 }
529− let workingOverridesWithErrors = validateWorkingOverrides . uniqMap <$> envsDyn
530− erroredOverride = M.filter ((/= mempty) . snd) <$> workingOverridesWithErrors
531− isValid = M.null <$> erroredOverride
532− (_, changedValues) <-
533− mapAccumDyn
534− ( \prev new ->
535− ( fmap (\(v, _) -> (v, mempty)) new
536− , new <> prev
537− )
538− )
539− mempty
540− (updated erroredOverride)
541− let updatedValues = restrictMapEv updatedKeys (updated workingOverridesWithErrors)
542− valChangedEvSelector = fanMap (clearedOvs <> updatedValues <> changedValues)
543− (splitE -> (clearedOvs, deletedOvs)) =
544− alignEventWithMaybe
545− ( \case
546− These keys m ->
547− Just $
548− let cleared = M.restrictKeys m keys
549− in (cleared, M.fromSet (const Nothing) (keys `S.difference` M.keysSet cleared))
550− _ -> Nothing
551− )
552− removedKeys
553− (updated workingOverridesWithErrors)
554− listChange =
555− deletedOvs <> (fmap . fmap) Just (restrictMapEv addedKeys (updated workingOverridesWithErrors))
556−
557− (splitE3 -> (updEv, removedKeys, updatedKeys)) <-
558− switchDyn . fmap F.fold
559− <$> listHoldWithKey
560− (validateWorkingOverrides . uniqMap $ initialOverrides)
561− listChange
562− ( \i val -> do
563− valDyn <- holdDyn val $ select valChangedEvSelector $ Const2 i
564− userActionEv <- envVarInput values valDyn
565− pure $ performUserOverrideAction (lookupDefaultConfig <$> dCfg) i <$> userActionEv
566− )
567− let addingIsEnabled = all (\(WorkingOverrideKey _ x, _) -> not . T.null $ x) . elemsUniq <$> envsDyn
568− case dCfg of
569− Just _ -> pure ()
570− Nothing -> loadingOverrides
571− pure (updated $ destructWorkingOverrides <$> envsDyn, isValid)
572−
573−restrictMapEv :: (Reflex t, Ord k) => Event t (Set k) -> Event t (Map k v) -> Event t (Map k v)
574−restrictMapEv =
575− alignEventWithMaybe
576− ( \case
577− These keys _ | S.null keys -> Nothing
578− These keys m -> Just $ M.restrictKeys m keys
579− _ -> Nothing
580− )
581−
582−validateWorkingOverrides ::
583− forall f.
584− Traversable f =>
585− f WorkingOverride ->
586− f (WorkingOverride, OverrideErrors)
587−validateWorkingOverrides overrides =
588− let (result, keyOccurrences :: MonoidalMap Text (Sum Int)) =
589− flip runState mempty $ forM overrides \override@(WorkingOverrideKey _ key, value') -> do
590− case value' of
591− WorkingDeletedValue _ -> pure ()
592− _ -> modify (<> MM.singleton key (Sum 1))
593− pure . (override,) . mconcat $
594− [ case MM.lookup key keyOccurrences of
595− Just (Sum n)
596− | n > 1 ->
597− overrideKeyErrors "You can not use the same key multiple times."
598− _ -> mempty
599− , if T.null key
600− then overrideKeyErrors "Keys can not be empty."
601− else mempty
602− , case value' of
603− WorkingCustomValue "" -> overrideValueErrors "Values can not be empty."
604− WorkingCustomValue _ -> mempty
605− WorkingDefaultValue "" -> overrideValueErrors "Values can not be empty."
606− WorkingDefaultValue _ -> mempty
607− WorkingDeletedValue _ -> mempty
608− ]
609− in result
610−
611−data OverrideErrors = OverrideErrors
612− { keyErrors :: Maybe (NonEmpty Text)
613− , valueErrors :: Maybe (NonEmpty Text)
614− }
615− deriving stock (Generic, Eq, Show)
616− deriving (Semigroup, Monoid) via Generically OverrideErrors
617−
618−overrideKeyErrors :: Text -> OverrideErrors
619−overrideKeyErrors x = mempty {keyErrors = Just $ pure x}
620−
621−overrideValueErrors :: Text -> OverrideErrors
622−overrideValueErrors x = mempty {valueErrors = Just $ pure x}
426+ let emptyItem = ("", CustomConfigValue $ Left $ CustomKey "")
427+ addedItemsCount <- foldDyn (const (fst . insertUniqStart ())) emptyUniqKeyMap clickEv
428+ addedOvsListDyn <- (fmap . fmap) (fmap snd . M.toList)
429+ <$> list (uniqMap <$> addedItemsCount)
430+ $ \_ ->
431+ envVarInput lookupOverride values emptyItem
432+ treeResCfg <-
433+ showOverrideTree
434+ ((== Just True) . fmap (T.null . T.strip) . getConfigValueText . snd)
435+ (isn't (_Ctor' @"DefaultConfigValue") . snd)
436+ (\_ v -> v)
437+ (\a _ _ -> envVarInput lookupOverride values (trace "a" a))
438+ initialConfig
439+ let resCfg :: Dynamic t [Dynamic t (Text, ConfigValue Text)]
440+ resCfg = (<> treeResCfg) <$> addedOvsListDyn
441+ addingIsEnabled = join $ fmap and . sequenceA . (fmap . fmap) (not . T.null . fst) <$> resCfg
442+ pure resCfg
623443
624444-- | Widget for entering a key-value pair.
625445envVarInput ::
626446 (MonadWidget t m) =>
447+ (Text -> Maybe Text) ->
627448 -- | The key values to suggest to the user
628449 Dynamic t [Text] ->
629450 -- | Current variable key and value.
630− Dynamic t (WorkingOverride, OverrideErrors) ->
631− m (Event t UserOverrideAction)
632−envVarInput values val = untilReadyEv' loadingOverride $ do
633− let kDyn = val <&> fst <&> \(WorkingOverrideKey _ x, _) -> x
634− -- Either <override present> <override deleted>
635− d <-
636− eitherDyn $
637− val <&> snd . fst <&> \case
638− WorkingCustomValue v -> Right (v, EditedOverrideFieldType)
639− WorkingDefaultValue v -> Right (v, DefaultOverrideFieldType)
640− WorkingDeletedValue v -> Left v
641− networkView >=> switchHold never $
642− d <&> \case
643− Right vtDyn -> do
644− let (vDyn, vTypeDyn) = splitDynPure vtDyn
645− (keyTextDyn, valTextDyn, closeEv) <-
646− overrideField
647− values
648− OverrideField
649− { fieldValue = kDyn
650− , fieldError = keyErrors . snd <$> val
651− , fieldDisabled =
652− val <&> fst <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
653− , fieldType =
654− val <&> fst <&> \(WorkingOverrideKey t _, _) -> case t of
655− CustomWorkingOverrideKey -> EditedOverrideFieldType
656− DefaultWorkingOverrideKey -> DefaultOverrideFieldType
657− }
658− OverrideField
659− { fieldValue = vDyn
660− , fieldError = valueErrors . snd <$> val
661− , fieldDisabled = pure False
662− , fieldType = vTypeDyn
663− }
664− pure $
665− leftmost
666− [ UpdateKey <$> updated keyTextDyn
667− , UpdateValue <$> updated valTextDyn
668− , closeEv $> DeleteOverride
669− ]
670− Left vDyn -> do
671− restoreEv <-
672− networkView >=> switchHold never $ do
673− v <- vDyn
674− k <- kDyn
675− pure $ deletedOverride k v
451+ WorkingOverride ->
452+ m (Dynamic t WorkingOverride)
453+envVarInput f keys val = mdo
454+ value' <- holdDyn val (leftmost [buttonValue, updated inputValue])
455+ (keyTextDyn, valTextDyn, buttonPressEv) <- configField keys value'
456+ let inputValue = do
457+ v <- valTextDyn
458+ k <- keyTextDyn
676459 pure $
677− flip push restoreEv $ \() -> do
678− v <- sample . current $ vDyn
679− pure $ UpdateValue <$> v
680−
681−data UserOverrideAction = UpdateKey !Text | UpdateValue !Text | DeleteOverride
682−
683−performUserOverrideAction ::
684− Maybe (Text -> Maybe Text) ->
685− Int ->
686− UserOverrideAction ->
687− -- | (endo, removed/cleared keys, updatedKeys)
688− (Endo WorkingOverrides, Set Int, Set Int)
689−performUserOverrideAction f i (UpdateValue v) = (,S.empty,S.singleton i) $
690− Endo $
691− updateUniq i $ \(k@(WorkingOverrideKey _ kt), _) ->
692− ( k
693− , case f >>= ($ kt) of
694− Just v' | v == v' -> WorkingDefaultValue v
695− _ -> WorkingCustomValue v
696− )
697−performUserOverrideAction _ i (UpdateKey k) = (,S.empty,S.singleton i) $
698− Endo $
699− updateUniq i $
700− \(_, v) -> (WorkingOverrideKey CustomWorkingOverrideKey k, v)
701−performUserOverrideAction f i DeleteOverride = (,S.singleton i,S.empty) $
702− Endo $ \m ->
703− case f of
704− Nothing -> updateUniq i (\(k, _) -> (k, WorkingDeletedValue Nothing)) m
705− Just _ -> case lookupUniq i m of
706− Nothing -> m
707− Just (WorkingOverrideKey DefaultWorkingOverrideKey k, _) ->
708− updateUniq i (const (WorkingOverrideKey DefaultWorkingOverrideKey k, WorkingDeletedValue (f >>= ($ k)))) m
709− Just (WorkingOverrideKey CustomWorkingOverrideKey _, _) -> deleteUniq i m
460+ ( k
461+ , case f k of
462+ Nothing -> CustomConfigValue $ Left $ CustomKey v
463+ Just x | x == v -> DefaultConfigValue v
464+ Just _ -> CustomConfigValue $ Right $ CustomValue v
465+ )
466+ buttonValue = flip push buttonPressEv $ \x ->
467+ Just <$> do
468+ k <- sample . current $ keyTextDyn
469+ (k,) <$> case x of
470+ ConfigFieldButtonClear -> do
471+ v <- case f k of
472+ Nothing -> sample . current $ valTextDyn
473+ Just v -> pure v
474+ pure $ CustomConfigValue $ Right $ DeletedValue $ Just v
475+ ConfigFieldButtonRecover -> do
476+ case f k of
477+ Nothing -> do
478+ -- the value is not in the default config
479+ v <- sample . current $ valTextDyn
480+ pure $ CustomConfigValue $ Left $ CustomKey v
481+ Just v -> do
482+ -- the value is in the default config
483+ pure $ DefaultConfigValue v
484+ pure $ value'
710485
711486holdDynMaybe :: (Reflex t, MonadHold t m) => Event t a -> m (Dynamic t (Maybe a))
712487holdDynMaybe ev = holdDyn Nothing $ fmapCheap Just ev
@@ -716,12 +491,6 @@ immediateNothing ev = do
716491 pb <- getPostBuild
717492 pure $ leftmost [pb $> Nothing, fmapCheap Just ev]
718493
719−attachDyn :: (Reflex t, MonadHold t m) => Behavior t a -> Dynamic t b -> m (Dynamic t (a, b))
720−attachDyn b d = do
721− currD <- sample . current $ d
722− currB <- sample b
723− holdDyn (currB, currD) (attach b $ updated d)
724−
725494holdClearingWith :: (Reflex t, MonadHold t m) => Event t a -> Event t () -> m (Dynamic t (Maybe a))
726495holdClearingWith aEv clear =
727496 holdDyn Nothing $ leftmost [fmapCheap Just aEv, fmapCheap (const Nothing) clear]
@@ -751,6 +520,3 @@ catchReturns :: (DomBuilder t m, MonadFix m) => (Event t () -> m a) -> m a
751520catchReturns f = mdo
752521 (divEl, a) <- el' "div" $ f $ ($> ()) . ffilter (== 13) $ domEvent Keypress divEl
753522 pure a
754−
755−splitE3 :: Reflex t => Event t (a, b, c) -> (Event t a, Event t b, Event t c)
756−splitE3 e = ((\(a, _, _) -> a) <$> e, (\(_, b, _) -> b) <$> e, (\(_, _, c) -> c) <$> e)