diff --git a/ChangeLog.md b/ChangeLog.md index ab5ac585..4b3e7420 100644 --- a/ChangeLog.md +++ b/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 diff --git a/frontend/Rhyolite/Frontend/Form.hs b/frontend/Rhyolite/Frontend/Form.hs index f7e81190..950e7235 100644 --- 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,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