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! :-)

3 files changed, 88 insertions, 21 deletions

diff --git a/frontend/app/Form/Input.hs b/frontend/app/Form/Input.hs
index 67a6d80..5e0feec 100644
--- a/frontend/app/Form/Input.hs
+++ b/frontend/app/Form/Input.hs
@@ -2,23 +2,58 @@ module Form.Input
   ( inputText,
     inputNumber,
     inputUnion,
-    TypeName(..),
-    Type(..)
+    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)
+  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 x
+
+instance A.FromJSON Type where
+  parseJSON = \case
+    A.Number x -> pure (IsNumber (realToFrac x))
+    A.String x -> pure (IsString 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 (<|>)
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 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