From 37208871ca1a03f117015829728aaa9a6267b928 Mon Sep 17 00:00:00 2001 From: iko Date: Thu, 14 Oct 2021 12:18:06 +0300 Subject: [PATCH] Various small frontend improvements (#140) * Disabled spell checking * Enter now submits forms * Open deployment page after creation --- octopod-frontend/src/Frontend/UIKit.hs | 1 + octopod-frontend/src/Frontend/Utils.hs | 6 ++ octopod-frontend/src/Page/Deployments.hs | 4 +- .../src/Page/Popup/EditDeployment.hs | 4 +- .../src/Page/Popup/NewDeployment.hs | 55 ++++++++++--------- 5 files changed, 41 insertions(+), 29 deletions(-) diff --git a/octopod-frontend/src/Frontend/UIKit.hs b/octopod-frontend/src/Frontend/UIKit.hs index a5d1194..6ede908 100644 --- a/octopod-frontend/src/Frontend/UIKit.hs +++ b/octopod-frontend/src/Frontend/UIKit.hs @@ -238,6 +238,7 @@ octopodTextInputDyn valuesDyn disabledDyn clssDyn placeholder inValDyn' errDyn = .~ ( "type" =: "text" <> "class" =: "input__widget" <> "placeholder" =: placeholder + <> "spellcheck" =: "false" ) & inputElementConfig_setValue .~ inValEv & inputElementConfig_initialValue .~ inVal diff --git a/octopod-frontend/src/Frontend/Utils.hs b/octopod-frontend/src/Frontend/Utils.hs index 7bc181b..c13986c 100644 --- a/octopod-frontend/src/Frontend/Utils.hs +++ b/octopod-frontend/src/Frontend/Utils.hs @@ -33,6 +33,7 @@ module Frontend.Utils applicationOverridesWidget, applicationOverridesWidgetSearched, debounceDyn, + catchReturns, ) where @@ -679,3 +680,8 @@ debounceDyn t d = do currD <- sample . current $ d ev <- debounce t (updated d) holdDyn currD ev + +catchReturns :: (DomBuilder t m, MonadFix m) => (Event t () -> m a) -> m a +catchReturns f = mdo + (divEl, a) <- el' "div" $ f $ ($> ()) . ffilter (== 13) $ domEvent Keypress divEl + pure a diff --git a/octopod-frontend/src/Page/Deployments.hs b/octopod-frontend/src/Page/Deployments.hs index 1df83b8..c7ce7f1 100644 --- a/octopod-frontend/src/Page/Deployments.hs +++ b/octopod-frontend/src/Page/Deployments.hs @@ -93,7 +93,9 @@ deploymentsWidget updAllEv dfis = do termDyn <- debounceDyn 0.3 termDyn' (okUpdEv, errUpdEv, editEv) <- deploymentsListWidget hReq updAllEv termDyn dfis pure (showNewDeploymentEv', deSearch <$> editEv) - void $ newDeploymentPopup showNewDeploymentEv never + newDepEv <- newDeploymentPopup showNewDeploymentEv never + setRoute $ newDepEv <&> \newDep -> DashboardRoute :/ Just (newDep ^. #name) + void $ editDeploymentPopup editEv never -- | Div wrappers. diff --git a/octopod-frontend/src/Page/Popup/EditDeployment.hs b/octopod-frontend/src/Page/Popup/EditDeployment.hs index 6b1bcb3..f071799 100644 --- a/octopod-frontend/src/Page/Popup/EditDeployment.hs +++ b/octopod-frontend/src/Page/Popup/EditDeployment.hs @@ -33,10 +33,10 @@ editDeploymentPopup :: Event t () -> -- | Event with a flag showing the current state of the request. m (Event t Bool) -editDeploymentPopup showEv hideEv = sidebar showEv hideEv $ \dfi -> mdo +editDeploymentPopup showEv hideEv = catchReturns $ \enterEv -> sidebar showEv hideEv $ \dfi -> mdo divClass "popup__body" $ mdo let dname = dfi ^. dfiName - (closeEv', saveEv) <- editDeploymentPopupHeader dname enabledDyn sentDyn + (closeEv', (enterEv <>) -> saveEv) <- editDeploymentPopupHeader dname enabledDyn sentDyn deploymentMDyn <- editDeploymentPopupBody dfi respEv respEv <- holdDyn (pure never) >=> networkView >=> switchHold never $ diff --git a/octopod-frontend/src/Page/Popup/NewDeployment.hs b/octopod-frontend/src/Page/Popup/NewDeployment.hs index ad795a4..a58af9e 100644 --- a/octopod-frontend/src/Page/Popup/NewDeployment.hs +++ b/octopod-frontend/src/Page/Popup/NewDeployment.hs @@ -8,7 +8,6 @@ module Page.Popup.NewDeployment (newDeploymentPopup) where import Control.Lens import Control.Monad import Data.Functor -import Data.Generics.Sum import Data.Monoid import qualified Data.Text as T import Reflex.Dom as R @@ -30,31 +29,35 @@ newDeploymentPopup :: Event t () -> -- | \"Close\" event. Event t () -> - m () -newDeploymentPopup showEv hideEv = void $ - sidebar showEv hideEv $ - const $ mdo - divClass "popup__body" $ mdo - (closeEv', saveEv) <- newDeploymentPopupHeader enabledDyn sentDyn - deploymentMDyn <- newDeploymentPopupBody respEv - respEv <- - holdDyn (pure never) >=> networkView >=> switchHold never $ - tagMaybe (current deploymentMDyn) saveEv <&> \dep -> do - pb <- getPostBuild - createEndpoint - (pure $ Right dep) - pb - sentDyn <- - holdDyn False $ - leftmost - [ True <$ saveEv - , False <$ respEv - ] - let successEv = - fmapMaybe (preview (_Ctor @"Success") <=< commandResponse) respEv - closeEv = leftmost [closeEv', successEv] - enabledDyn = zipDynWith (&&) (not <$> sentDyn) (isJust <$> deploymentMDyn) - pure (never, closeEv) + m (Event t Deployment) +newDeploymentPopup showEv hideEv = + catchReturns $ \enterEv -> + sidebar showEv hideEv $ + const $ mdo + divClass "popup__body" $ mdo + (closeEv', (enterEv <>) -> saveEv) <- newDeploymentPopupHeader enabledDyn sentDyn + deploymentMDyn <- newDeploymentPopupBody (snd <$> respEv) + respEv <- + holdDyn (pure never) >=> networkView >=> switchHold never $ + tagMaybe (current deploymentMDyn) saveEv <&> \dep -> do + pb <- getPostBuild + fmap (dep,) + <$> createEndpoint + (pure $ Right dep) + pb + sentDyn <- + holdDyn False $ + leftmost + [ True <$ saveEv + , False <$ respEv + ] + let successEv = + respEv `fforMaybe` \case + (dep, commandResponse -> Just Success {}) -> Just dep + _ -> Nothing + closeEv = leftmost [closeEv', successEv $> ()] + enabledDyn = zipDynWith (&&) (not <$> sentDyn) (isJust <$> deploymentMDyn) + pure (successEv, closeEv) -- | The header of sidebar contains control buttons: \"Save\" and \"Close\". newDeploymentPopupHeader ::