From 962f04ddc339db8e1f10e5f4eb68c0d5039e1e5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Sun, 13 Oct 2024 15:09:21 +0200 Subject: wip: add forms for unions --- frontend/app/Form/Input.hs | 72 ++++++++++++++++++++++++++++++++++++++ frontend/app/Schema.hs | 86 +++++++++++++++++++++++++++++++++++----------- 2 files changed, 137 insertions(+), 21 deletions(-) diff --git a/frontend/app/Form/Input.hs b/frontend/app/Form/Input.hs index 7619326..67a6d80 100644 --- a/frontend/app/Form/Input.hs +++ b/frontend/app/Form/Input.hs @@ -1,13 +1,85 @@ module Form.Input ( inputText, inputNumber, + inputUnion, + TypeName(..), + Type(..) ) where +import Control.Applicative +import Control.Arrow (first, second) +import Data.Map qualified as M import Form.Internal import Miso import Miso.String (MisoString, fromMisoString, null, strip, toMisoString) +data TypeName = StringType | NumberType + deriving (Eq, Ord) + +data Type = IsNumber Double | IsString MisoString + +inputUnion :: MisoString -> [TypeName] -> Form (TypeName, M.Map TypeName MisoString) (Maybe Type) +inputUnion label types = + foldl1 (<|>) + <$> mapM + ( \case + StringType -> + mapValues + ( \(selectedType, typeInputs) -> + ( selectedType == StringType, + M.findWithDefault "" StringType typeInputs + ) + ) + ( \(checked, inputString) (selectedType, typeInputs) -> + ( if checked then StringType else selectedType, + M.insert StringType inputString typeInputs + ) + ) + $ fmap (fmap IsString) + $ withRadio + $ inputText label + NumberType -> + mapValues + ( \(selectedType, typeInputs) -> + ( selectedType == NumberType, + M.findWithDefault "" NumberType typeInputs + ) + ) + ( \(checked, inputString) (selectedType, typeInputs) -> + ( if checked then NumberType else selectedType, + M.insert NumberType inputString typeInputs + ) + ) + $ fmap (fmap IsNumber) + $ withRadio + $ inputNumber label + ) + types + +radio :: Form Bool Bool +radio = + Form + { view = \checked -> + [ div_ [] $ + [ input_ + [ type_ "radio", + checked_ checked, + onClick (not checked) + ] + ] + ], + fill = Right + } + +withRadio :: Form i o -> Form (Bool, i) (Maybe o) +withRadio form = + (\(checked, x) -> if checked then Just x else Nothing) + <$> liftA2 + (,) + (mapValues fst (first . const) radio) + (mapValues snd (second . const) form) + inputNumber :: MisoString -> Form MisoString Double inputNumber label = let parse :: MisoString -> Either MisoString Double diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs index b1618d3..8e3b7da 100644 --- a/frontend/app/Schema.hs +++ b/frontend/app/Schema.hs @@ -51,12 +51,14 @@ instance A.FromJSONKey MisoString where data Property = Type MisoString | Reference MisoString + | Union [MisoString] deriving (Show, Eq) instance A.FromJSON Property where parseJSON = A.withObject "Property" $ \v -> (Type <$> v A..: "type") <|> (Reference <$> v A..: "$ref") + <|> (fmap Union $ traverse (A..: "type") =<< v A..: "oneOf") viewSchema :: Schema -> View action viewSchema schema = @@ -69,6 +71,7 @@ viewSchema schema = ( case v of Type v -> toMisoString v Reference v -> "reference to " <> toMisoString v + Union vs -> Miso.String.intercalate " or " vs ), text (if k `S.member` schema.required then "" else "?") ] @@ -112,24 +115,67 @@ schemaTable collection schema values = schemaForm :: Schema -> F.Form A.Object A.Object schemaForm schema = - 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) + fmap mergeJson . sequence . catMaybes $ + ( \((AK.fromText . fromMisoString) -> k, v) -> + case v of + Type "string" -> + Just $ + 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.inputText (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.inputText (toMisoString (AK.toString k))) + ) + Type "number" -> + Just $ + if toMisoString (AK.toText k) `S.member` schema.required + then + AM.singleton k + <$> ( F.mapValues (getO k) (setO k) $ + fmap ((A.Number . fromFloatDigits)) . F.mapValues fromJson toJson $ + F.inputNumber (toMisoString (AK.toString k)) + ) + else + AM.singleton k + <$> ( F.mapValues (getO k) (setO k) + $ fmap (maybe A.Null (A.Number . fromFloatDigits)) + . F.mapValues fromJson toJson + $ F.optional (F.inputNumber (toMisoString (AK.toString k))) + ) + Reference _ -> Nothing + Union typeStrings -> + let mapOutput = \case + F.IsString s -> A.String s + F.IsNumber i -> A.Number (fromIntegral i) + typeStringToType "number" = F.NumberType + typeStringToType "string" = F.StringType + in Just $ + if toMisoString (AK.toText k) `S.member` schema.required + then + AM.singleton k + <$> ( F.mapValues (getO k) (setO k) $ + F.mapValues fromJson toJson $ + F.mapValues _getter _setter $ + fmap mapOutput <$> + F.inputUnion (toMisoString (AK.toString k)) (map typeStringToType typeStrings) + ) + else undefined + -- AM.singleton k + -- <$> ( F.mapValues (getO k) (setO k) + -- $ fmap (maybe A.Null (A.Number . fromFloatDigits)) + -- . F.mapValues fromJson toJson + -- $ F.optional unionForm + -- ) + ) + <$> (M.toList schema.properties) mergeJson :: [A.Object] -> A.Object mergeJson = foldl' mergeObject AM.empty @@ -139,12 +185,10 @@ 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 _ - | otherwise = A.String (fromMisoString x) +toJson x _ = A.String (fromMisoString x) getO :: AK.Key -> A.Object -> A.Value getO k kvs = fromMaybe A.Null (AM.lookup k kvs) -- cgit v1.2.3