From 85a430beb6c9098e3812001939295059d3ae4ef7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= <kmein@posteo.de>
Date: Sun, 13 Oct 2024 13:00:30 +0200
Subject: frontend: support number forms
---
frontend/app/Form/Input.hs | 35 +++++++++++++++++++++++----
frontend/app/Page/NewCollection.hs | 2 +-
frontend/app/Schema.hs | 48 ++++++++++++++++++--------------------
frontend/frontend.cabal | 1 +
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
--
cgit v1.2.3