frontend: support number forms

4 files changed, 56 insertions, 30 deletions

diff --git a/frontend/app/Form/Input.hs b/frontend/app/Form/Input.hs
index 99fd821..7619326 100644
--- a/frontend/app/Form/Input.hs
+++ b/frontend/app/Form/Input.hs
@@ -1,14 +1,41 @@
 module Form.Input
-  ( input,
+  ( inputText,
+    inputNumber,
   )
 where
 
 import Form.Internal
 import Miso
-import Miso.String (MisoString, null, strip)
+import Miso.String (MisoString, fromMisoString, null, strip, toMisoString)
 
-input :: MisoString -> Form MisoString MisoString
-input label =
+inputNumber :: MisoString -> Form MisoString Double
+inputNumber label =
+  let parse :: MisoString -> Either MisoString Double
+      parse i =
+        let i' = strip i
+         in if Miso.String.null i' then Left "required" else Right (read (fromMisoString i'))
+   in Form
+        { view = \i ->
+            [ div_ [] $
+                [ label_ [] $
+                    [ text label,
+                      div_ [] $
+                        [ input_
+                            [ type_ "number",
+                              value_ (toMisoString (show i)),
+                              onInput id
+                            ],
+                          div_ [] $
+                            [either text (\_ -> text "") (parse i)]
+                        ]
+                    ]
+                ]
+            ],
+          fill = parse
+        }
+
+inputText :: MisoString -> Form MisoString MisoString
+inputText label =
   let parse :: MisoString -> Either MisoString MisoString
       parse i =
         let i' = strip i
diff --git a/frontend/app/Page/NewCollection.hs b/frontend/app/Page/NewCollection.hs
index bc789f8..4b2cf9c 100644
--- a/frontend/app/Page/NewCollection.hs
+++ b/frontend/app/Page/NewCollection.hs
@@ -55,4 +55,4 @@ viewModel m = do
 
 collectionForm :: F.Form MisoString MisoString
 collectionForm =
-  F.input "name"
+  F.inputText "name"
diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs
index c15e1d1..b1618d3 100644
--- a/frontend/app/Schema.hs
+++ b/frontend/app/Schema.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-
 module Schema
   ( Schema,
     viewSchema,
@@ -19,10 +16,11 @@ import Data.Aeson.KeyMap qualified as AM
 import Data.List
 import Data.Map qualified as M
 import Data.Maybe
+import Data.Scientific (fromFloatDigits)
 import Data.Set qualified as S
 import Form qualified as F
 import Miso
-import Miso.String (MisoString, fromMisoString, toMisoString)
+import Miso.String (MisoString, fromMisoString, intercalate, toMisoString)
 import Route
 
 data Schema = Schema
@@ -114,26 +112,24 @@ schemaTable collection schema values =
 
 schemaForm :: Schema -> F.Form A.Object A.Object
 schemaForm schema =
-  fmap mergeJson . sequence $
-    ( \((AK.fromText . fromMisoString) -> k, v) ->
-        case v of
-          Type "string" ->
-            if toMisoString (AK.toText k) `S.member` schema.required
-              then
-                AM.singleton k
-                  <$> ( F.mapValues (getO k) (setO k) $
-                          fmap (A.String . fromMisoString) . F.mapValues fromJson toJson $
-                            F.input (toMisoString (AK.toString k))
-                      )
-              else
-                AM.singleton k
-                  <$> ( F.mapValues (getO k) (setO k)
-                          $ fmap (maybe A.Null (A.String . fromMisoString))
-                            . F.mapValues fromJson toJson
-                          $ F.optional (F.input (toMisoString (AK.toString k)))
-                      )
-    )
-      <$> (M.toList schema.properties)
+  let handleOptional k toJson form
+        | toMisoString (AK.toText k) `S.member` schema.required = toJson <$> form
+        | otherwise = maybe A.Null toJson <$> F.optional form
+      typeForm k (Type "number") =
+        Just $ handleOptional k (A.Number . fromFloatDigits) $ F.inputNumber (toMisoString (AK.toString k))
+      typeForm k (Type "string") =
+        Just $
+          handleOptional k (A.String . fromMisoString) $
+            F.inputText (toMisoString (AK.toString k))
+      typeForm _ (Reference _) = Nothing
+   in fmap mergeJson . sequence . catMaybes $
+        ( \((AK.fromText . fromMisoString) -> k, v) ->
+            fmap (AM.singleton k)
+              . F.mapValues (getO k) (setO k)
+              . F.mapValues fromJson toJson
+              <$> typeForm k v
+        )
+          <$> (M.toList schema.properties)
 
 mergeJson :: [A.Object] -> A.Object
 mergeJson = foldl' mergeObject AM.empty
@@ -143,10 +139,12 @@ mergeObject kvs kvs' = AM.union kvs kvs'
 
 fromJson :: A.Value -> MisoString
 fromJson (A.String x) = toMisoString x
+fromJson (A.Number x) = toMisoString (show x)
 fromJson _ = ""
 
 toJson :: MisoString -> A.Value -> A.Value
-toJson x _ = A.String (fromMisoString x)
+toJson x _
+  | otherwise = A.String (fromMisoString x)
 
 getO :: AK.Key -> A.Object -> A.Value
 getO k kvs = fromMaybe A.Null (AM.lookup k kvs)
diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal
index f01aced..baa11e4 100644
--- a/frontend/frontend.cabal
+++ b/frontend/frontend.cabal
@@ -47,6 +47,7 @@ executable frontend
         mtl,
         neat-interpolation,
         safe,
+        scientific,
         split,
         text,
         utf8-string