refactor `Form` module

2 files changed, 86 insertions, 0 deletions

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"]
+         ]