Frontend: Add validation functions for textArea and dropdown

(cherry picked from commit a5c5482)
obsidiansystems · Aug 1, 2019 · 5b334cd · 5b334cd
1 parent 36cd436
commit 5b334cd
Show file tree

Hide file tree

Showing 2 changed files with 133 additions and 27 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -4,6 +4,9 @@ This project's release branch is `master`. This log is written from the perspect
 
 ## 2019-06-14 - Unreleased
 
+* Add `validationDropdown` and `validationTextArea`
+  * Add an extra type parameter `v` specifying the widget value type (typically `Text`) to `ValidationConfig`
+  * Add `mkValidationConfig` which is like `defValidationConfig` but takes the initial value
 * Add `withLoggingMinLevel` function in `Rhyolite.Backend.Logging` which allows you to pick the fallback filter when no other filters match.
 * Bump obelisk to a version that no longer uses `*Tag` classes.
 * Add alternative to groundhog's `==.`, which has severe performance issues before version 0.10 (to which we can't yet upgrade). See `Rhyolite.Backend.DB.===.`.

diff --git a/frontend/Rhyolite/Frontend/Form.hs b/frontend/Rhyolite/Frontend/Form.hs
@@ -17,6 +17,7 @@ import Control.Monad.Except
 import Data.Bifunctor
 import Data.Functor.Compose
 import Data.Map (Map)
+import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Text (Text)
@@ -118,10 +119,10 @@ manageValidity validate' validator errorText renderInput = do
   return v
 
 manageValidation
-  :: (DomBuilder t m, MonadHold t m)
-  => (Dynamic t Text -> DynValidation t e a) -- Validation
-  -> m (InputElement EventResult (DomBuilderSpace m) t) -- Render input
-  -> m (InputElement EventResult (DomBuilderSpace m) t, DynValidation t e a)
+  :: (DomBuilder t m, HasValue w, Value w ~ Dynamic t v, MonadHold t m)
+  => (Dynamic t v -> DynValidation t e a) -- Validation
+  -> m w -- Render input
+  -> m (w, DynValidation t e a)
 manageValidation validator renderInput = do
   input <- renderInput
   return (input, validator $ value input)
@@ -135,6 +136,9 @@ validateNonEmpty m = fromEither $ do
   guardEither () $ not $ T.null txt
   return txt
 
+validateJust :: Maybe a -> Validation () a
+validateJust = fromEither . maybe (Left ()) pure
+
 validateEmail :: Text -> Validation () Text
 validateEmail m = fromEither $ do
   ne <- toEither $ validateNonEmpty m
@@ -150,34 +154,50 @@ validateUniqueName name otherNames = fromEither $ do
   guardEither () $ not $ Set.member name otherNames
   return name
 
-data ValidationConfig t m e a = ValidationConfig
+-- | Configure how to perform validation of an input widget
+--
+-- - `e` is the error type of the validation
+-- - `a` is the result type of the validation
+-- - `v` is the value used (typically `Text`) internally by the widget
+data ValidationConfig t m e a v = ValidationConfig
   { _validationConfig_feedback :: Either (Dynamic t e) (Dynamic t a) -> m ()
   -- ^ For displaying the error in the browser with manual styling.
   , _validationConfig_errorText :: e -> Text
   -- ^ For the base HTML form validation, in which errors are non-empty strings.
-  , _validationConfig_validation :: Dynamic t Text -> DynValidation t e a
+  , _validationConfig_validation :: Dynamic t v -> DynValidation t e a
   -- ^ Input is always being reevaluated, including when external dynamics
   -- "mixed in" with this change. But rather than pushing changes downstream,
   -- downstream needed to ask for them (poll) with the 'validate' field.
   , _validationConfig_initialAttributes :: Map AttributeName Text
   , _validationConfig_validAttributes :: Map AttributeName Text
   , _validationConfig_invalidAttributes :: Map AttributeName Text
-  , _validationConfig_initialValue :: Text
-  , _validationConfig_setValue :: Maybe (Event t Text)
+  , _validationConfig_initialValue :: v
+  , _validationConfig_setValue :: Maybe (Event t v)
   , _validationConfig_validate :: Event t ()
   -- ^ When to show validations and open the gate so downstream gets a new
   -- result. Fresh errors is the price for fresh results.
   }
 
-defValidationConfig :: DomBuilder t m => ValidationConfig t m Text a
-defValidationConfig = ValidationConfig
+-- | Like mkValidationConfig but for monoidal widget values
+defValidationConfig
+  :: (DomBuilder t m, Monoid v)
+  => ValidationConfig t m Text a v
+defValidationConfig = mkValidationConfig mempty
+
+-- | Make a ValidationConfig with base values.
+mkValidationConfig
+  :: DomBuilder t m
+  => v
+  -- ^ Initial value to use in the widget
+  -> ValidationConfig t m Text a v
+mkValidationConfig ini = ValidationConfig
   { _validationConfig_feedback = const blank
   , _validationConfig_errorText = id
   , _validationConfig_validation = const $ toDynValidation $ pure $ Left "Validation not configured"
   , _validationConfig_initialAttributes = mempty
   , _validationConfig_validAttributes = mempty
   , _validationConfig_invalidAttributes = mempty
-  , _validationConfig_initialValue = ""
+  , _validationConfig_initialValue = ini
   , _validationConfig_setValue = Nothing
   , _validationConfig_validate = never
   }
@@ -187,41 +207,124 @@ data ValidationInput t m e a = ValidationInput
   , _validationInput_value :: DynValidation t e a
   }
 
+data ValidationTextArea t m e a = ValidationTextArea
+  { _validationTextArea_input :: TextAreaElement EventResult (DomBuilderSpace m) t
+  , _validationTextArea_value :: DynValidation t e a
+  }
+
+data ValidationDropdown t e a = ValidationDropdown
+  { _validationDropdown_input :: Dropdown t (Maybe a)
+  , _validationDropdown_value :: DynValidation t e a
+  }
+
 instance HasValue (ValidationInput t m e a) where
   type Value (ValidationInput t m e a) = DynValidation t e a
   value = _validationInput_value
 
+instance HasValue (ValidationTextArea t m e a) where
+  type Value (ValidationTextArea t m e a) = DynValidation t e a
+  value = _validationTextArea_value
+
+instance HasValue (ValidationDropdown t e a) where
+  type Value (ValidationDropdown t e a) = DynValidation t e a
+  value = _validationDropdown_value
+
 instance Reflex t => HasDomEvent t (ValidationInput t m e a) en where
   type DomEventType (ValidationInput t m e a) en = DomEventType (InputElement EventResult m t) en
   domEvent en = domEvent en . _validationInput_input
 
+instance Reflex t => HasDomEvent t (ValidationTextArea t m e a) en where
+  type DomEventType (ValidationTextArea t m e a) en = DomEventType (TextAreaElement EventResult m t) en
+  domEvent en = domEvent en . _validationTextArea_input
+
 validationInput
-  :: (DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m)
-  => ValidationConfig t m e a
+  :: (DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m, Semigroup e)
+  => ValidationConfig t m e a Text
   -> m (ValidationInput t m e a)
 validationInput config = do
   (vi, feedback) <- validationInputWithFeedback config
   feedback
   return vi
 
+validationTextArea
+  :: (DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m, Semigroup e)
+  => ValidationConfig t m e a Text
+  -> m (ValidationTextArea t m e a)
+validationTextArea config = do
+  (vi, feedback) <- validationTextAreaWithFeedback config
+  feedback
+  return vi
+
+validationDropdown
+  :: (DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m, Semigroup e, Ord a)
+  => Maybe a
+  -> Dynamic t (Map (Maybe a) Text)
+  -> ValidationConfig t m e a (Maybe a)
+  -> m (ValidationDropdown t e a)
+validationDropdown k0 options config = do
+  (vi, feedback) <- validationDropdownWithFeedback k0 options config
+  feedback
+  return vi
+
 validationInputWithFeedback
-  :: (DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m)
-  => ValidationConfig t m e a
+  :: ( DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m
+     , Semigroup e , Reflex t
+     )
+  => ValidationConfig t m e a Text
   -> m (ValidationInput t m e a, m ())
-validationInputWithFeedback config = do
-  let validation' = _validationConfig_validate config
-  rec (input, dValidated) <- manageValidation (_validationConfig_validation config) $ do
-        inputElement $ def
-          & initialAttributes .~ _validationConfig_initialAttributes config
-          & modifyAttributes .~ inputAttrs
-          & inputElementConfig_initialValue .~ _validationConfig_initialValue config
-          & inputElementConfig_setValue %~ maybe id const (_validationConfig_setValue config)
-      let eValidated = tagPromptlyDyn (fromDynValidation dValidated) validation'
+validationInputWithFeedback config = validationCustomInputWithFeedback config ValidationInput $ \inputAttrs ->
+  inputElement $ def
+    & initialAttributes .~ _validationConfig_initialAttributes config
+    & modifyAttributes .~ (fmap Just <$> inputAttrs)
+    & inputElementConfig_initialValue .~ _validationConfig_initialValue config
+    & inputElementConfig_setValue %~ maybe id const (_validationConfig_setValue config)
+
+validationTextAreaWithFeedback
+  :: ( DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m
+     , Semigroup e , Reflex t
+     )
+  => ValidationConfig t m e a Text
+  -> m (ValidationTextArea t m e a, m ())
+validationTextAreaWithFeedback config = validationCustomInputWithFeedback config ValidationTextArea $ \inputAttrs ->
+  textAreaElement $ def
+    & initialAttributes .~ _validationConfig_initialAttributes config
+    & modifyAttributes .~ (fmap Just <$> inputAttrs)
+    & textAreaElementConfig_initialValue .~ _validationConfig_initialValue config
+    & textAreaElementConfig_setValue %~ maybe id const (_validationConfig_setValue config)
+
+validationDropdownWithFeedback
+  :: ( DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m
+     , Semigroup e, Reflex t, Ord a
+     )
+  => Maybe a
+  -> Dynamic t (Map (Maybe a) Text)
+  -> ValidationConfig t m e a (Maybe a)
+  -> m (ValidationDropdown t e a, m ())
+validationDropdownWithFeedback k0 options config = validationCustomInputWithFeedback config ValidationDropdown $
+  \inputAttrs -> do
+    attrs <- holdDyn (_validationConfig_initialAttributes config) inputAttrs
+    let attrs' = Map.mapKeysMonotonic (\(AttributeName _ v) -> v) <$> attrs
+    dropdown k0 options $ def
+      & dropdownConfig_attributes .~ attrs'
+      & dropdownConfig_setValue %~ maybe id const (_validationConfig_setValue config)
+
+validationCustomInputWithFeedback
+  :: ( DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m
+     , Semigroup e, Reflex t, HasValue w, Value w ~ Dynamic t v
+     )
+  => ValidationConfig t m e a v
+  -> (w -> DynValidation t e a -> vi)
+  -> (Event t (Map AttributeName Text) -> m w)
+  -> m (vi, m ())
+validationCustomInputWithFeedback config mkVi w = do
+  let validate' = _validationConfig_validate config
+  rec (input, dValidated) <- manageValidation (_validationConfig_validation config) $ w inputAttrs
+      let eValidated = tagPromptlyDyn (fromDynValidation dValidated) validate'
           inputAttrs = ffor eValidated $ \case
-            Left _ -> fmap Just $ _validationConfig_invalidAttributes config
-            Right _ -> fmap Just $ _validationConfig_validAttributes config
+            Left _ -> _validationConfig_invalidAttributes config
+            Right _ -> _validationConfig_validAttributes config
   val <- eitherDyn $ fromDynValidation dValidated
   let feedback = dyn_ $ _validationConfig_feedback config <$> val
-  return $ (ValidationInput input dValidated, feedback)
+  return (mkVi input dValidated, feedback)
 
 makeLenses ''ValidationConfig