about summary refs log tree commit diff
path: root/users/Profpatsch/htmx-experiment/src/ValidationParseT.hs
diff options
context:
space:
mode:
authorProfpatsch <mail@profpatsch.de>2023-05-28T15·39+0200
committerProfpatsch <mail@profpatsch.de>2023-07-13T20·50+0000
commitee21f725a38855e43fd8e82eb8c6c6fc99aca235 (patch)
tree7c49c266b0bc0262857b72cbb9b828bd96621f22 /users/Profpatsch/htmx-experiment/src/ValidationParseT.hs
parent6a15e8e71ab318b47e4c62d90f8e541b45df7fd4 (diff)
feat(users/Profpatsch): init HtmxExperiment r/6408
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 <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
Diffstat (limited to 'users/Profpatsch/htmx-experiment/src/ValidationParseT.hs')
-rw-r--r--users/Profpatsch/htmx-experiment/src/ValidationParseT.hs40
1 files changed, 40 insertions, 0 deletions
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