From 342ebdf61b3b9021b9e58cfce607e96a6e7ae54e Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Tue, 4 Jun 2024 09:28:10 +0200
Subject: refactor `Form` module
---
frontend/app/Form.hs | 8 ++++
frontend/app/Form/Input.hs | 26 ++++++++++++
frontend/app/Form/Internal.hs | 60 +++++++++++++++++++++++++++
frontend/app/Main.hs | 95 +++++--------------------------------------
4 files changed, 104 insertions(+), 85 deletions(-)
create mode 100644 frontend/app/Form.hs
create mode 100644 frontend/app/Form/Input.hs
create mode 100644 frontend/app/Form/Internal.hs
(limited to 'frontend/app')
diff --git a/frontend/app/Form.hs b/frontend/app/Form.hs
new file mode 100644
index 0000000..f07487b
--- /dev/null
+++ b/frontend/app/Form.hs
@@ -0,0 +1,8 @@
+module Form
+ ( module Form.Internal,
+ module Form.Input,
+ )
+where
+
+import Form.Input
+import Form.Internal
diff --git a/frontend/app/Form/Input.hs b/frontend/app/Form/Input.hs
new file mode 100644
index 0000000..a9648c4
--- /dev/null
+++ b/frontend/app/Form/Input.hs
@@ -0,0 +1,26 @@
+module Form.Input
+ ( string,
+ )
+where
+
+import Data.Text qualified as T
+import Form.Internal
+import Miso
+import Miso.String (toMisoString)
+
+string :: String -> Form T.Text T.Text
+string label =
+ Form
+ { view = \i ->
+ [ div_ [] $
+ [ label_ [] $
+ [ text (toMisoString label),
+ input_
+ [ type_ "text",
+ value_ (toMisoString i)
+ ]
+ ]
+ ]
+ ],
+ fill = \i -> Right i
+ }
diff --git a/frontend/app/Form/Internal.hs b/frontend/app/Form/Internal.hs
new file mode 100644
index 0000000..7782368
--- /dev/null
+++ b/frontend/app/Form/Internal.hs
@@ -0,0 +1,60 @@
+module Form.Internal
+ ( Form (..),
+ mapValues,
+ runForm,
+ )
+where
+
+import Miso
+
+data Form i o = Form
+ { view :: i -> [View i],
+ fill :: i -> Either String o
+ }
+
+instance Functor (Form i) where
+ fmap f (Form {view, fill}) =
+ Form
+ { fill = fmap f . fill,
+ ..
+ }
+
+instance Applicative (Form i) where
+ pure x =
+ Form
+ { view = const [],
+ fill = const (Right x)
+ }
+
+ f <*> x =
+ Form
+ { view = liftA2 (<>) f.view x.view,
+ fill = \i -> ($) <$> f.fill i <*> x.fill i
+ }
+
+instance Monad (Form i) where
+ form >>= mkForm =
+ Form
+ { view = \i ->
+ form.view i
+ <> case form.fill i of
+ Right x -> (mkForm x).view i
+ Left _ -> [],
+ fill = \i -> case form.fill i of
+ Right x -> (mkForm x).fill i
+ Left e -> Left e
+ }
+
+mapValues :: (i' -> i) -> (i -> i' -> i') -> Form i o -> Form i' o
+mapValues get set (Form {view, fill}) =
+ Form
+ { view = \i -> fmap (flip set i) <$> view (get i),
+ fill = fill . get
+ }
+
+runForm :: Form i o -> i -> View (Either i o)
+runForm (Form {view}) i =
+ div_ [] $
+ (fmap Left <$> view i)
+ <> [ button_ [type_ "submit"] [text "submit"]
+ ]
diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs
index d995b95..45b828b 100644
--- a/frontend/app/Main.hs
+++ b/frontend/app/Main.hs
@@ -22,6 +22,7 @@ import Data.Function
import Data.List
import Data.Map qualified as M
import Data.Text qualified as T
+import Form qualified as F
import GHC.Generics (Generic)
import Miso
import Miso.String (toMisoString)
@@ -164,7 +165,7 @@ viewModel model =
( either
err
( fmap (either FormChanged FormSubmitted)
- . flip viewForm (A.Object AM.empty)
+ . flip F.runForm (A.Object AM.empty)
. schemaForm
)
)
@@ -188,15 +189,16 @@ viewSchema schema =
)
<$> (M.toList properties)
-schemaForm :: Schema -> Form A.Value A.Value
+schemaForm :: Schema -> F.Form A.Value A.Value
schemaForm schema =
- mapOutput mergeJson . sequence $
+ fmap mergeJson . sequence $
case schema.type_ of
Object properties ->
( \(AK.fromString -> k, "string") ->
- mapOutput (A.Object . AM.singleton k) $
- mapValues (getO k) (setO k) $
- jsonString (AK.toString k)
+ A.Object . AM.singleton k
+ <$> ( F.mapValues (getO k) (setO k) $
+ jsonString (AK.toString k)
+ )
)
<$> (M.toList properties)
@@ -219,85 +221,8 @@ getO k (A.Object kvs) = fromMaybe A.Null (AM.lookup k kvs)
setO :: AK.Key -> A.Value -> A.Value -> A.Value
setO k v (A.Object kvs) = A.Object (AM.insert k v kvs)
-data Form i o = Form
- { view :: i -> [View i],
- fill :: i -> Either String o
- }
-
-instance Functor (Form i) where
- fmap f (Form {view, fill}) =
- Form
- { fill = fmap f . fill,
- ..
- }
-
-instance Applicative (Form i) where
- pure x =
- Form
- { view = const [],
- fill = const (Right x)
- }
- Form {view = viewF, fill = fillF} <*> Form {view = viewX, fill = fillX} =
- Form
- { view = \i ->
- let f = viewF i
- x = viewX i
- in f <> x,
- fill = \i ->
- let f = fillF i
- x = fillX i
- in ($) <$> f <*> x
- }
-
-instance Monad (Form i) where
- (Form {view = viewM, fill = fillM}) >>= mkF =
- Form
- { view = \i ->
- viewM i
- <> case fillM i of
- Right x -> (mkF x).view i
- Left _ -> [],
- fill = \i -> case fillM i of
- Right x -> (mkF x).fill i
- Left e -> Left e
- }
-
-mapValues :: (i' -> i) -> (i -> i' -> i') -> Form i o -> Form i' o
-mapValues get set (Form {view, fill}) =
- Form
- { view = \i -> fmap (flip set i) <$> view (get i),
- fill = fill . get
- }
-
-mapOutput :: (o -> o') -> Form i o -> Form i o'
-mapOutput = fmap
-
-viewForm :: Form i o -> i -> View (Either i o)
-viewForm (Form {view}) i =
- div_ [] $
- (fmap Left <$> view i)
- <> [ button_ [type_ "submit"] [text "submit"]
- ]
-
-jsonString :: String -> Form A.Value A.Value
-jsonString = mapOutput A.String . mapValues fromJson toJson . string
-
-string :: String -> Form T.Text T.Text
-string label =
- Form
- { view = \i ->
- [ div_ [] $
- [ label_ [] $
- [ text (toMisoString label),
- input_
- [ type_ "text",
- value_ (toMisoString i)
- ]
- ]
- ]
- ],
- fill = \i -> Right i
- }
+jsonString :: String -> F.Form A.Value A.Value
+jsonString = fmap A.String . F.mapValues fromJson toJson . F.string
viewPosts :: [A.Value] -> View Action
viewPosts posts = ol_ [] (viewPost <$> posts)
--
cgit v1.2.3