add forms for unions

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