From fe07f05b8e4f0c7e6eec2714ee1ed5a67b227eda 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: add forms for unions --- frontend/app/Form/Input.hs | 107 +++++++++++++++++++++++++++++++++++++ frontend/app/Form/Internal.hs | 1 + frontend/app/Schema.hs | 119 ++++++++++++++++++++++++++++++++++-------- 3 files changed, 205 insertions(+), 22 deletions(-) (limited to 'frontend') diff --git a/frontend/app/Form/Input.hs b/frontend/app/Form/Input.hs index 7619326..3539e96 100644 --- a/frontend/app/Form/Input.hs +++ b/frontend/app/Form/Input.hs @@ -1,13 +1,120 @@ module Form.Input ( inputText, inputNumber, + inputUnion, + TypeName (..), + Type (..), + typeName, + stringToTypeName, ) where +import Control.Applicative +import Control.Arrow (first, second) +import Data.Aeson qualified as A +import Data.Map qualified as M +import Data.Maybe (fromMaybe) import Form.Internal +import GHC.Generics (Generic) import Miso import Miso.String (MisoString, fromMisoString, null, strip, toMisoString) +data TypeName = StringType | NumberType + deriving (Eq, Ord, Generic) + +instance IsEmpty (TypeName, M.Map TypeName MisoString) where + isEmpty (k, kvs) = isEmpty (fromMaybe "" (M.lookup k kvs)) + +instance A.FromJSON TypeName + +instance A.ToJSON TypeName + +instance A.FromJSONKey TypeName + +instance A.ToJSONKey TypeName + +data Type = IsNumber Double | IsString MisoString + +instance A.ToJSON Type where + toJSON (IsNumber x) = A.Number (realToFrac x) + toJSON (IsString x) = A.String (fromMisoString x) + +instance A.FromJSON Type where + parseJSON = \case + A.Number x -> pure (IsNumber (realToFrac x)) + A.String x -> pure (IsString (toMisoString x)) + _ -> fail "" + +typeName :: Type -> TypeName +typeName (IsNumber _) = NumberType +typeName (IsString _) = StringType + +stringToTypeName :: MisoString -> TypeName +stringToTypeName "number" = NumberType +stringToTypeName "string" = StringType +stringToTypeName _ = StringType + +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/Form/Internal.hs b/frontend/app/Form/Internal.hs index 35d59e7..6677b2d 100644 --- a/frontend/app/Form/Internal.hs +++ b/frontend/app/Form/Internal.hs @@ -3,6 +3,7 @@ module Form.Internal mapValues, runForm, optional, + IsEmpty (..), ) where diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs index 13f37b3..c10cffe 100644 --- a/frontend/app/Schema.hs +++ b/frontend/app/Schema.hs @@ -17,8 +17,9 @@ 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 +import Safe data Schema = Schema { id :: MisoString, @@ -48,12 +49,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 = @@ -66,6 +69,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 "?") ] @@ -109,24 +113,69 @@ 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 (map F.stringToTypeName -> typeStrings) -> + let inputFromOutput = \case + A.String x -> pure (F.StringType, M.singleton F.StringType (toMisoString x)) + A.Number x -> pure (F.NumberType, M.singleton F.NumberType (toMisoString (show x))) + _ -> fail "" + inputFromInput = A.fromJSON + inputDef = + ( fromMaybe F.StringType (headMay typeStrings), + M.empty + ) + in Just $ + if toMisoString (AK.toText k) `S.member` schema.required + then + AM.singleton k + <$> ( fmap A.toJSON $ + F.mapValues (getInput k inputFromOutput inputFromInput inputDef) (setInput k A.toJSON) $ + F.inputUnion (toMisoString (AK.toString k)) typeStrings + ) + else + AM.singleton k + <$> ( fmap A.toJSON $ + F.mapValues (getInput k inputFromOutput inputFromInput inputDef) (setInput k A.toJSON) $ + F.optional (F.inputUnion (toMisoString (AK.toString k)) typeStrings) + ) + _ -> Nothing + ) + <$> (M.toList schema.properties) mergeJson :: [A.Object] -> A.Object mergeJson = foldl' mergeObject AM.empty @@ -136,15 +185,41 @@ 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) setO :: AK.Key -> A.Value -> A.Object -> A.Object setO k v kvs = AM.insert k v kvs + +-- | Used in `mapValues (getInput ...) (setInput ..)`. +-- +-- Suppose *input" is an `A.Object`, this function is concerned with getting a sub-form model from within that object, given a *key* and the *subform's type*. +-- +-- The input model can be in three different states: +-- +-- - (1) The input object has been converted from an output model, no modification has been done on it. The value in question corresponds to the output model, which may be different from the corresponding form value. +-- - (2) The input object had been modified, and so the value in question conforms structurally to the input value. +-- - (3) The input object is in an undefined state, ie. this should not happen. +-- +-- The first three arguments `(A.Value -> A.Result i)`, `(A.Value -> A.Result i)`, `i` correspond to these cases and are tested for in order of (2), (1), (3). +getInput :: + AK.Key -> + (A.Value -> A.Result i) -> + (A.Value -> A.Result i) -> + i -> + A.Object -> + i +getInput k f1 f2 f3 kvs = + let v = getO k kvs + in case f2 v <|> f1 v of + A.Error _ -> f3 + A.Success x -> x + +setInput :: AK.Key -> (i -> A.Value) -> i -> A.Object -> A.Object +setInput k f i kvs = + setO k (f i) kvs -- cgit v1.2.3