refactor Form module

frontend/app/Form.hs

@@ -0,0 +1,8 @@
+module Form
+  ( module Form.Internal,
+    module Form.Input,
+  )
+where
+
+import Form.Input
+import Form.Internal

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
+    }

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

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)

frontend/frontend.cabal

@@ -11,6 +11,11 @@ extra-doc-files: CHANGELOG.md
 executable frontend
     main-is:            Main.hs
     hs-source-dirs:     app
+    other-modules:
+        Form
+        Form.Input
+        Form.Internal
+
     default-language:   GHC2021
     default-extensions:
         CPP OverloadedStrings RecordWildCards DeriveAnyClass