diff options
Diffstat (limited to 'client/src/Component')
| -rw-r--r-- | client/src/Component/Input.hs | 69 | ||||
| -rw-r--r-- | client/src/Component/Select.hs | 54 |
2 files changed, 76 insertions, 47 deletions
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index d679f9b..abdc51c 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -40,7 +40,7 @@ defaultInputIn = InputIn data InputOut t a = InputOut { _inputOut_raw :: Dynamic t Text - , _inputOut_value :: Dynamic t (Maybe (Validation Text a)) + , _inputOut_value :: Dynamic t (Validation Text a) , _inputOut_enter :: Event t () } @@ -64,27 +64,14 @@ input inputIn reset validate = do value = R._textInput_value textInput - containerAttr = R.ffor validatedValue (\v -> + containerAttr = R.ffor inputError (\e -> M.singleton "class" $ T.intercalate " " [ "textInput" - , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else "" + , if Maybe.isJust e then "error" else "" ]) - -- Clear validation errors after reset - delayedReset <- R.delay (0.1 :: NominalDiffTime) reset - - validatedValue <- R.holdDyn Nothing $ R.attachWith - (\v (clearValidation, validateEmpty) -> - if clearValidation - then Nothing - else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v))) - (R.current value) - (R.leftmost - [ const (False, True) <$> resetClic - , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) - , const (False, False) <$> validate - , const (True, False) <$> delayedReset - ]) + let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v)) + inputError <- getInputError valueWithValidation validate (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do @@ -108,7 +95,7 @@ input inputIn reset validate = do return R.never R.divClass "errorMessage" $ - R.dynText . fmap validationError $ validatedValue + R.dynText . fmap (Maybe.fromMaybe "") $ inputError return (textInput, resetClic) @@ -116,10 +103,46 @@ input inputIn reset validate = do return $ InputOut { _inputOut_raw = value - , _inputOut_value = validatedValue + , _inputOut_value = fmap snd valueWithValidation , _inputOut_enter = enter } -validationError :: Maybe (Validation Text a) -> Text -validationError (Just (Failure e)) = e -validationError _ = "" +getInputError + :: forall t m a b c. MonadWidget t m + => Dynamic t (Text, Validation Text a) + -> Event t c + -> m (Dynamic t (Maybe Text)) +getInputError validatedValue validate = do + let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue + errorEvent = R.updated errorDynamic + delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent + fmap (fmap fst) $ R.foldDyn + (\event (err, hasBeenResetted) -> + case event of + ModifiedEvent t -> + (Nothing, T.null t) + + ValidateEvent e -> + (e, False) + + DelayEvent e -> + if hasBeenResetted then + (Nothing, False) + else + (e, False) + ) + (Nothing, False) + (R.leftmost + [ fmap (\(t, _) -> ModifiedEvent t) errorEvent + , fmap (\(_, e) -> DelayEvent e) delayedError + , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate + ]) + +validationError :: (Validation Text a) -> Maybe Text +validationError (Failure e) = Just e +validationError _ = Nothing + +data InputEvent + = ModifiedEvent Text + | DelayEvent (Maybe Text) + | ValidateEvent (Maybe Text) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 43a8a6e..01ed37a 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -4,14 +4,17 @@ module Component.Select , select ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Validation (Validation (Failure, Success)) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R -import qualified Common.Msg as Msg +import qualified Common.Msg as Msg +import qualified Util.Validation as ValidationUtil data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text @@ -24,25 +27,33 @@ data (Reflex t) => SelectIn t a b c = SelectIn } data SelectOut t a = SelectOut - { _selectOut_value :: Dynamic t a + { _selectOut_value :: Dynamic t (Validation Text a) } select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) select selectIn = do rec - let containerAttr = R.ffor hasError (\e -> + let containerAttr = R.ffor showedError (\e -> M.singleton "class" $ T.intercalate " " [ "selectInput" - , if e then "error" else "" + , if Maybe.isJust e then "error" else "" ]) - hasError <- R.holdDyn False $ R.attachWith - (\v clearError -> not clearError && not (_selectIn_isValid selectIn v)) - (R.current value) - (R.leftmost - [ const False <$> _selectIn_validate selectIn - , const True <$> _selectIn_reset selectIn - ]) + validatedValue = + R.ffor value (\v -> + if _selectIn_isValid selectIn v then + Success v + else + Failure (Msg.get Msg.Form_NonEmpty)) + + maybeError = + fmap ValidationUtil.maybeError validatedValue + + showedError <- R.holdDyn Nothing $ R.leftmost + [ const Nothing <$> _selectIn_reset selectIn + , R.updated maybeError + , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn) + ] value <- R.elDynAttr "div" containerAttr $ do R.el "label" $ R.text (_selectIn_label selectIn) @@ -60,16 +71,11 @@ select selectIn = do (_selectIn_values selectIn) (R.def { R._dropdownConfig_setValue = setValue }) - errorMessage <- R.holdDyn "" $ R.attachWith - (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") - (R.current value) - (_selectIn_validate selectIn) - R.divClass "errorMessage" . R.dynText $ - R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "") + R.ffor showedError (Maybe.fromMaybe "") return value return SelectOut - { _selectOut_value = value + { _selectOut_value = validatedValue } |