wip: add union forms - some suggestionsunion-forms

I have not tested this, but I fixed the type errors. Maybe some of these
thoughts help in some way in finishing the PR! :-)

1 files changed, 49 insertions, 18 deletions

diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs
index 8e3b7da..a11c658 100644
--- a/frontend/app/Schema.hs
+++ b/frontend/app/Schema.hs
@@ -22,6 +22,7 @@ import Form qualified as F
 import Miso
 import Miso.String (MisoString, fromMisoString, intercalate, toMisoString)
 import Route
+import Safe
 
 data Schema = Schema
   { id :: MisoString,
@@ -151,29 +152,31 @@ schemaForm schema =
                             $ 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
+          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
-                        <$> ( 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)
+                        <$> ( fmap A.toJSON $
+                                F.mapValues (getInput k inputFromOutput inputFromInput inputDef) (setInput k A.toJSON) $
+                                  F.inputUnion (toMisoString (AK.toString k)) 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
-                    --       )
+                    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)
 
@@ -195,3 +198,31 @@ 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