Frontend: Add validation functions for textArea and dropdown

(cherry picked from commit a5c5482)

ChangeLog.md

@@ -6,6 +6,18 @@ This project's release branch is `master`. This log is written from the perspect
 
 * 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 `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
+* Remove the "HasView" and "HasRequest" classes, and the general concept of having a type level "app" identifier. Instead, everything is explicitly parametrised on query and request types directly, and the query type is no longer *required* to be a Functor/Align/etc. so that Vessel becomes an option for defining queries and views.
+* Remove the "Request" class, as it has been subsumed by more general machinery. You can use deriveArgDict from constraints-extras and deriveJSONGADT from aeson-gadt-th on your request datatypes to obtain the same powers (and more).
+* In its place, there is a Request type synonym which stands for (ForallF ToJSON r, Has ToJSON r, FromJSON (Some r), Has FromJSON r). 
+* Added standardPipeline as a good example of a last argument you can use for serveDbOverWebsockets, in the case that you have a Functor-style query/view type. It now uses condense/disperse from the Vessel library.
+* Added vesselPipeline similarly for the case where you're using a functor-parametric container type (such as Vessel) for your queries and views.
+* Added a DiffQuery type class which allows us to specify how queries are subtracted. We were doing this in an ad-hoc fashion based on Align instances before, but the generalisation of query types meant that we could no longer assume this was an option.
+* If you have a Functor-style query/view, the 'standardDiffQuery' function can be used to implement the 'DiffQuery' instance for it.
+* If you're using Vessel, to implement DiffQuery you can use subtractV which is a consequence of the View typeclass.
+* 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.===.`.
 
 ## 2019-05-08 - Unreleased

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,136 @@ 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)
+
+combineValidators
+ :: (Reflex t, Monad m, Semigroup e)
+ => (Dynamic t v -> DynValidation t e a)
+ -> Maybe (Dynamic t v -> m (DynValidation t e a))
+ -> Dynamic t v -> m (DynValidation t e a)
+combineValidators pValidator mValidator t =
+ case mValidator of
+ Nothing -> pure $ pValidator t
+ Just mv -> do
+ r <- mv t
+ pure $ pValidator t *> r
 
 makeLenses ''ValidationConfig