refactor Form module

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)