From fe07f05b8e4f0c7e6eec2714ee1ed5a67b227eda Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= <kmein@posteo.de>
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 +
 2 files changed, 108 insertions(+)

(limited to 'frontend/app/Form')

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
 
-- 
cgit v1.2.3