add forms

frontend/app/Main.hs

@@ -1,6 +1,7 @@
 module Main where
 
 #ifndef ghcjs_HOST_OS
+import Data.Maybe
 import Data.String
 import Language.Javascript.JSaddle.Warp as JSaddle
 import Network.HTTP.Simple
@@ -13,10 +14,14 @@ import Miso.String qualified as J
 #endif
 
 import Data.Aeson qualified as A
+import Data.Aeson.Key qualified as AK
+import Data.Aeson.KeyMap qualified as AM
 import Data.ByteString.Lazy.Char8 qualified as LB
 import Data.Default
 import Data.Function
+import Data.List
 import Data.Map qualified as M
+import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Miso
 import Miso.String (toMisoString)
@@ -66,6 +71,8 @@ data Action
   | SetSchema (Either String Schema)
   | FetchPosts
   | SetPosts (Either String [A.Value])
+  | FormChanged A.Value
+  | FormSubmitted A.Value
   deriving (Show, Eq)
 
 #ifndef ghcjs_HOST_OS
@@ -103,6 +110,8 @@ updateModel action m =
       let setPosts :: Either String [A.Value] -> Model -> Model
           setPosts posts m = m {posts = Just posts}
        in noEff (setPosts posts m)
+    FormChanged _ -> noEff m
+    FormSubmitted _ -> noEff m
 
 fetchSchema :: JSM (Either String Schema)
 fetchSchema =
@@ -149,7 +158,17 @@ viewModel :: Model -> View Action
 viewModel model =
   div_ [] $
     [ maybe (text "..") (either err viewSchema) model.schema,
-      maybe (text "..") (either err viewPosts) model.posts
+      maybe (text "..") (either err viewPosts) model.posts,
+      maybe
+        (text "..")
+        ( either
+            err
+            ( fmap (either FormChanged FormSubmitted)
+                . flip viewForm (A.Object AM.empty)
+                . schemaForm
+            )
+        )
+        model.schema
     ]
 
 err :: String -> View Action
@@ -169,6 +188,117 @@ viewSchema schema =
         )
           <$> (M.toList properties)
 
+schemaForm :: Schema -> Form A.Value A.Value
+schemaForm schema =
+  mapOutput 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)
+        )
+          <$> (M.toList properties)
+
+mergeJson :: [A.Value] -> A.Value
+mergeJson = foldl' mergeObject (A.Object AM.empty)
+
+mergeObject :: A.Value -> A.Value -> A.Value
+mergeObject (A.Object kvs) (A.Object kvs') = A.Object (AM.union kvs kvs')
+
+fromJson :: A.Value -> T.Text
+fromJson (A.String x) = x
+fromJson _ = ""
+
+toJson :: T.Text -> A.Value -> A.Value
+toJson x _ = A.String x
+
+getO :: AK.Key -> A.Value -> A.Value
+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
+    }
+
 viewPosts :: [A.Value] -> View Action
 viewPosts posts = ol_ [] (viewPost <$> posts)
   where

frontend/frontend.cabal

@@ -15,11 +15,12 @@ executable frontend
     default-extensions:
         CPP OverloadedStrings RecordWildCards DeriveAnyClass
         DuplicateRecordFields LambdaCase OverloadedRecordDot
-        NoFieldSelectors
+        NoFieldSelectors ViewPatterns
 
     ghc-options:
         -Wall -fno-warn-name-shadowing -fno-warn-ambiguous-fields
         -fno-warn-incomplete-patterns -fno-warn-orphans
+        -fno-warn-incomplete-uni-patterns
 
     build-depends:
         aeson,