From ee21f725a38855e43fd8e82eb8c6c6fc99aca235 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sun, 28 May 2023 17:39:21 +0200 Subject: feat(users/Profpatsch): init HtmxExperiment MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit I’m playing around with htmx (server-side html snippet rendering), this is a simple registration form and some form validation that happens in-place. Change-Id: I29602a7881e66c3e4d1cc0ba8027f98e0bd3461c Reviewed-on: https://cl.tvl.fyi/c/depot/+/8660 Tested-by: BuildkiteCI Reviewed-by: Profpatsch Autosubmit: Profpatsch --- .../htmx-experiment/src/ValidationParseT.hs | 40 ++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 users/Profpatsch/htmx-experiment/src/ValidationParseT.hs (limited to 'users/Profpatsch/htmx-experiment/src/ValidationParseT.hs') diff --git a/users/Profpatsch/htmx-experiment/src/ValidationParseT.hs b/users/Profpatsch/htmx-experiment/src/ValidationParseT.hs new file mode 100644 index 000000000000..ffb6c2f395cb --- /dev/null +++ b/users/Profpatsch/htmx-experiment/src/ValidationParseT.hs @@ -0,0 +1,40 @@ +module ValidationParseT where + +import Control.Monad.Logger (MonadLogger) +import Control.Selective (Selective) +import Data.Error.Tree +import Data.Functor.Compose (Compose (..)) +import PossehlAnalyticsPrelude +import ServerErrors + +-- | A simple way to create an Applicative parser that parses from some environment. +-- +-- Use with DerivingVia. Grep codebase for examples. +newtype ValidationParseT env m a = ValidationParseT {unValidationParseT :: env -> m (Validation (NonEmpty Error) a)} + deriving + (Functor, Applicative, Selective) + via ( Compose + ((->) env) + (Compose m (Validation (NonEmpty Error))) + ) + +-- | Helper that runs the given parser and throws a user error if the parsing failed. +runValidationParseTOrUserError :: + forall validationParseT env m a. + ( Coercible validationParseT (ValidationParseT env m a), + MonadLogger m, + MonadThrow m + ) => + -- | toplevel error message to throw if the parsing fails + Error -> + -- | The parser which should be run + validationParseT -> + -- | input to the parser + env -> + m a +{-# INLINE runValidationParseTOrUserError #-} +runValidationParseTOrUserError contextError parser env = + (coerce @_ @(ValidationParseT _ _ _) parser).unValidationParseT env + >>= \case + Failure errs -> throwUserErrorTree (errorTree contextError errs) + Success a -> pure a -- cgit 1.4.1