aboutsummaryrefslogtreecommitdiffstats
path: root/frontend/app/Schema.hs
diff options
context:
space:
mode:
authorLibravatar KierĂ¡n Meinhardt <kmein@posteo.de>2024-10-13 15:09:21 +0200
committerLibravatar Alexander Foremny <aforemny@posteo.de>2025-02-19 18:09:40 +0100
commitfe07f05b8e4f0c7e6eec2714ee1ed5a67b227eda (patch)
treed95d66c13d77a91fe5e2f07e1b5c4c8652c48fb8 /frontend/app/Schema.hs
parentd0d1215913dbdd44b62cf584100a9db18aaf83b2 (diff)
add forms for unions
Diffstat (limited to 'frontend/app/Schema.hs')
-rw-r--r--frontend/app/Schema.hs119
1 files changed, 97 insertions, 22 deletions
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