{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.HyperView.Forms
  ( FromForm (..)
  , FromFormF (..)
  , GenFields (..)
  , fieldNames
  , FieldName (..)
  , FormFields (..)
  , Field
  , InputType (..)
  , Input (..)
  , field
  , label
  , input
  , checkbox
  , radioGroup
  , radio
  , select
  , form
  , textarea
  , submit
  , formData
  , FormOptions (..)
  , Validated (..)
  , isInvalid
  , invalidText
  , validate
  , Identity

    -- * Re-exports
  , FE.FromFormKey
  , Generic
  , GFieldsGen (..)
  , GenField (..)
  , Form (..)
  )
where

import Data.Bifunctor (first)
import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.String.Conversions (cs)
import Data.Text (Text, pack)
import Effectful
import GHC.Generics
import Text.Casing (kebab)
import Web.Atomic.Types hiding (Selector)
import Web.FormUrlEncoded (Form (..), FormOptions (..))
import Web.FormUrlEncoded qualified as FE
import Web.Hyperbole.Data.Param
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Request
import Web.Hyperbole.Effect.Response (parseError)
import Web.Hyperbole.HyperView.Event (onSubmit)
import Web.Hyperbole.HyperView.Input (Option (..), checked)
import Web.Hyperbole.HyperView.Types
import Web.Hyperbole.View


------------------------------------------------------------------------------
-- FORM PARSING
------------------------------------------------------------------------------

{- | Simple types that be decoded from form data

@
data ContactForm = ContactForm
  { name :: Text
  , age :: Int
  , isFavorite :: Bool
  , planet :: Planet
  , moon :: Moon
  }
  deriving (Generic, FromForm)
@
-}
class FromForm (form :: Type) where
  fromForm :: FE.Form -> Either String form
  default fromForm :: (Generic form, GFormParse (Rep form)) => FE.Form -> Either String form
  fromForm Form
f = Rep form Any -> form
forall a x. Generic a => Rep a x -> a
forall x. Rep form x -> form
to (Rep form Any -> form)
-> Either String (Rep form Any) -> Either String form
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form -> Either String (Rep form Any)
forall p. Form -> Either String (Rep form p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either String (f p)
gFormParse Form
f


{- | A Higher-Kinded type that can be parsed from a 'Web.FormUrlEncoded.Form'

@
data UserForm f = UserForm
  { user :: Field f User
  , age :: Field f Int
  , pass1 :: Field f Text
  , pass2 :: Field f Text
  }
  deriving (Generic, FromFormF, GenFields Validated, GenFields FieldName)
@
-}
class FromFormF (f :: (Type -> Type) -> Type) where
  fromFormF :: FE.Form -> Either String (f Identity)
  default fromFormF :: (Generic (f Identity), GFormParse (Rep (f Identity))) => FE.Form -> Either String (f Identity)
  fromFormF Form
f = Rep (f Identity) Any -> f Identity
forall a x. Generic a => Rep a x -> a
forall x. Rep (f Identity) x -> f Identity
to (Rep (f Identity) Any -> f Identity)
-> Either String (Rep (f Identity) Any)
-> Either String (f Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form -> Either String (Rep (f Identity) Any)
forall p. Form -> Either String (Rep (f Identity) p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either String (f p)
gFormParse Form
f


-- Any FromFormF can be parsed using fromForm @(form Identity)
-- we can't make it an instance because it is an orphan instance
instance (FromFormF form) => FromForm (form Identity) where
  fromForm :: Form -> Either String (form Identity)
fromForm = Form -> Either String (form Identity)
forall (form :: (* -> *) -> *).
FromFormF form =>
Form -> Either String (form Identity)
fromFormF


-- | Parse a full type from a submitted form body
formData :: forall form es. (FromForm form, Hyperbole :> es) => Eff es form
formData :: forall form (es :: [Effect]).
(FromForm form, Hyperbole :> es) =>
Eff es form
formData = do
  Form
f <- Eff es Form
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Form
formBody
  let ef :: Either String form
ef = forall form. FromForm form => Form -> Either String form
fromForm @form Form
f :: Either String form
  (String -> Eff es form)
-> (form -> Eff es form) -> Either String form -> Eff es form
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Eff es form
forall (es :: [Effect]) a. (Hyperbole :> es) => String -> Eff es a
parseError form -> Eff es form
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String form
ef


------------------------------------------------------------------------------
-- GEN FIELDS: Generate a type from selector names
------------------------------------------------------------------------------

{- | Generate a Higher Kinded record with all selectors filled with default values. See 'GenField'

@
data UserForm f = UserForm
  { user :: Field f User
  , age :: Field f Int
  , pass1 :: Field f Text
  , pass2 :: Field f Text
  }
  deriving (Generic, FromFormF, GenFields Validated, GenFields FieldName)
@

@
newContactForm :: 'View' NewContact ()
newContactForm = do
  row ~ pad 10 . gap 10 . border 1 $ do
    target Contacts () $ do
      contactForm AddUser (genFields :: ContactForm Maybe)
    col $ do
      space
      'button' CloseForm ~ btnLight $ \"Cancel\"
@
-}
class GenFields f (form :: (Type -> Type) -> Type) where
  genFields :: form f
  default genFields :: (Generic (form f), GFieldsGen (Rep (form f))) => form f
  genFields = Rep (form f) Any -> form f
forall a x. Generic a => Rep a x -> a
forall x. Rep (form f) x -> form f
to Rep (form f) Any
forall p. Rep (form f) p
forall {k} (f :: k -> *) (p :: k). GFieldsGen f => f p
gFieldsGen


{- | Generate FieldNames for a form

▶️ [Forms](https://hyperbole.live/forms)

> data TodoForm f = TodoForm
>   { task :: Field f Text
>   }
>   deriving (Generic, FromFormF, GenFields FieldName)
>
> todoForm :: FilterTodo -> View AllTodos ()
> todoForm filt = do
>   let f :: TodoForm FieldName = fieldNames
>   row ~ border 1 $ do
>     el ~ pad 8 $ do
>       button (ToggleAll filt) Icon.chevronDown ~ width 32 . hover (color Primary)
>     form SubmitTodo ~ grow $ do
>       field f.task $ do
>         input TextInput ~ pad 12 @ placeholder "What needs to be done?" . value ""
-}
fieldNames :: forall form. (GenFields FieldName form) => form FieldName
fieldNames :: forall (form :: (* -> *) -> *).
GenFields FieldName form =>
form FieldName
fieldNames = form FieldName
forall (f :: * -> *) (form :: (* -> *) -> *).
GenFields f form =>
form f
genFields


-- Given a selector, generate the type
class GenField a where
  genField :: String -> a


instance GenField (FieldName a) where
  genField :: String -> FieldName a
genField String
s = Text -> FieldName a
forall {k} (a :: k). Text -> FieldName a
FieldName (Text -> FieldName a) -> Text -> FieldName a
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s


instance GenField (Validated a) where
  genField :: String -> Validated a
genField = Validated a -> String -> Validated a
forall a b. a -> b -> a
const Validated a
forall {k} (a :: k). Validated a
NotInvalid


instance GenField (Maybe a) where
  genField :: String -> Maybe a
genField String
_ = Maybe a
forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- FORM VIEWS
------------------------------------------------------------------------------

-- | Context that allows form fields
newtype FormFields id = FormFields id
  deriving ((forall x. FormFields id -> Rep (FormFields id) x)
-> (forall x. Rep (FormFields id) x -> FormFields id)
-> Generic (FormFields id)
forall x. Rep (FormFields id) x -> FormFields id
forall x. FormFields id -> Rep (FormFields id) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall id x. Rep (FormFields id) x -> FormFields id
forall id x. FormFields id -> Rep (FormFields id) x
$cfrom :: forall id x. FormFields id -> Rep (FormFields id) x
from :: forall x. FormFields id -> Rep (FormFields id) x
$cto :: forall id x. Rep (FormFields id) x -> FormFields id
to :: forall x. Rep (FormFields id) x -> FormFields id
Generic)
  deriving newtype (Encoded -> Either String (FormFields id)
FormFields id -> Encoded
(FormFields id -> Encoded)
-> (Encoded -> Either String (FormFields id))
-> ViewId (FormFields id)
forall id. ViewId id => Encoded -> Either String (FormFields id)
forall id. ViewId id => FormFields id -> Encoded
forall a.
(a -> Encoded) -> (Encoded -> Either String a) -> ViewId a
$ctoViewId :: forall id. ViewId id => FormFields id -> Encoded
toViewId :: FormFields id -> Encoded
$cparseViewId :: forall id. ViewId id => Encoded -> Either String (FormFields id)
parseViewId :: Encoded -> Either String (FormFields id)
ViewId)


{- | Type-safe \<form\>. Calls (Action id) on submit

@
formView :: 'View' AddContact ()
formView = do
  form Submit ~ gap 15 . pad 10 . flexCol $ do
    'el' ~ Style.h1 $ \"Add Contact\"

    -- Make sure these names match the field names used by FormParse / formData
    field \"name\" $ do
      label $ do
        text \"Contact Name\"
        input Username @ placeholder \"contact name\" ~ Style.input

    field \"age\" $ do
      label $ do
        text \"Age\"
        input Number @ placeholder \"age\" . value \"0\" ~ Style.input

    field \"isFavorite\" $ do
      label $ do
        row ~ gap 10 $ do
          checkbox False ~ width 32
          text \"Favorite?\"

    col ~ gap 5 $ do
      'el' $ text \"Planet\"
      field \"planet\" $ do
        radioGroup Earth $ do
          planet Mercury
          planet Venus
          planet Earth
          planet Mars

    field \"moon\" $ do
      label $ do
        text \"Moon\"
        select Callisto ~ Style.input $ do
          option Titan \"Titan\"
          option Europa \"Europa\"
          option Callisto \"Callisto\"
          option Mimas \"Mimas\"

    submit \"Submit\" ~ btn
 where
  planet val =
    label ~ flexRow . gap 10 $ do
      radio val ~ width 32
      text (pack (show val))
@
-}
form :: (ViewAction (Action id)) => Action id -> View (FormFields id) () -> View id ()
form :: forall id.
ViewAction (Action id) =>
Action id -> View (FormFields id) () -> View id ()
form Action id
a View (FormFields id) ()
cnt = do
  Text -> View id () -> View id ()
forall c. Text -> View c () -> View c ()
tag Text
"form" (View id () -> View id ())
-> (Attributes (View id () -> View id ())
    -> Attributes (View id () -> View id ()))
-> View id ()
-> View id ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Action id
-> Attributes (View id () -> View id ())
-> Attributes (View id () -> View id ())
forall id a.
(ViewAction (Action id), Attributable a) =>
Action id -> Attributes a -> Attributes a
onSubmit Action id
a (View id () -> View id ()) -> View id () -> View id ()
forall a b. (a -> b) -> a -> b
$ do
    (id -> FormFields id) -> View (FormFields id) () -> View id ()
forall ctx c.
(ViewState ctx ~ ViewState c) =>
(c -> ctx) -> View ctx () -> View c ()
runChildView id -> FormFields id
forall id. id -> FormFields id
FormFields View (FormFields id) ()
cnt


-- | Button that submits the 'form'
submit :: View (FormFields id) () -> View (FormFields id) ()
submit :: forall id. View (FormFields id) () -> View (FormFields id) ()
submit = Text -> View (FormFields id) () -> View (FormFields id) ()
forall c. Text -> View c () -> View c ()
tag Text
"button" (View (FormFields id) () -> View (FormFields id) ())
-> (Attributes (View (FormFields id) () -> View (FormFields id) ())
    -> Attributes (View (FormFields id) () -> View (FormFields id) ()))
-> View (FormFields id) ()
-> View (FormFields id) ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Text
-> Attributes (View (FormFields id) () -> View (FormFields id) ())
-> Attributes (View (FormFields id) () -> View (FormFields id) ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"type" Text
"submit"


-- | Form FieldName. This is embeded as the name attribute, and refers to the key need to parse the form when submitted. See 'fieldNames'
newtype FieldName a = FieldName {forall {k} (a :: k). FieldName a -> Text
value :: Text}
  deriving newtype (Int -> FieldName a -> ShowS
[FieldName a] -> ShowS
FieldName a -> String
(Int -> FieldName a -> ShowS)
-> (FieldName a -> String)
-> ([FieldName a] -> ShowS)
-> Show (FieldName a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> FieldName a -> ShowS
forall k (a :: k). [FieldName a] -> ShowS
forall k (a :: k). FieldName a -> String
$cshowsPrec :: forall k (a :: k). Int -> FieldName a -> ShowS
showsPrec :: Int -> FieldName a -> ShowS
$cshow :: forall k (a :: k). FieldName a -> String
show :: FieldName a -> String
$cshowList :: forall k (a :: k). [FieldName a] -> ShowS
showList :: [FieldName a] -> ShowS
Show, String -> FieldName a
(String -> FieldName a) -> IsString (FieldName a)
forall a. (String -> a) -> IsString a
forall k (a :: k). String -> FieldName a
$cfromString :: forall k (a :: k). String -> FieldName a
fromString :: String -> FieldName a
IsString, Maybe Text -> Either String (FieldName a)
ParamValue -> Either String (FieldName a)
(ParamValue -> Either String (FieldName a))
-> (Maybe Text -> Either String (FieldName a))
-> FromParam (FieldName a)
forall a.
(ParamValue -> Either String a)
-> (Maybe Text -> Either String a) -> FromParam a
forall k (a :: k). Maybe Text -> Either String (FieldName a)
forall k (a :: k). ParamValue -> Either String (FieldName a)
$cparseParam :: forall k (a :: k). ParamValue -> Either String (FieldName a)
parseParam :: ParamValue -> Either String (FieldName a)
$cdecodeFormValue :: forall k (a :: k). Maybe Text -> Either String (FieldName a)
decodeFormValue :: Maybe Text -> Either String (FieldName a)
FromParam, FieldName a -> ParamValue
(FieldName a -> ParamValue) -> ToParam (FieldName a)
forall a. (a -> ParamValue) -> ToParam a
forall k (a :: k). FieldName a -> ParamValue
$ctoParam :: forall k (a :: k). FieldName a -> ParamValue
toParam :: FieldName a -> ParamValue
ToParam)


-- | Display a 'FormField'. See 'form' and 'Form'
field
  :: forall (id :: Type) (a :: Type)
   . FieldName a
  -> View (Input id a) ()
  -> View (FormFields id) ()
field :: forall id a.
FieldName a -> View (Input id a) () -> View (FormFields id) ()
field FieldName a
fn =
  (FormFields id -> Input id a)
-> View (Input id a) () -> View (FormFields id) ()
forall ctx c.
(ViewState ctx ~ ViewState c) =>
(c -> ctx) -> View ctx () -> View c ()
runChildView (\(FormFields id
i) -> id -> FieldName a -> Input id a
forall id a. id -> FieldName a -> Input id a
Input id
i FieldName a
fn)


-- | Choose one for 'input's to give the browser autocomplete hints
data InputType
  = -- TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete
    NewPassword
  | CurrentPassword
  | Username
  | Email
  | Number
  | TextInput
  | Name
  | OneTimeCode
  | Organization
  | StreetAddress
  | Country
  | CountryName
  | PostalCode
  | Search
  deriving (Int -> InputType -> ShowS
[InputType] -> ShowS
InputType -> String
(Int -> InputType -> ShowS)
-> (InputType -> String)
-> ([InputType] -> ShowS)
-> Show InputType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InputType -> ShowS
showsPrec :: Int -> InputType -> ShowS
$cshow :: InputType -> String
show :: InputType -> String
$cshowList :: [InputType] -> ShowS
showList :: [InputType] -> ShowS
Show)


data Input (id :: Type) (a :: Type) = Input
  { forall id a. Input id a -> id
id :: id
  , forall id a. Input id a -> FieldName a
inputName :: FieldName a
  }
  deriving ((forall x. Input id a -> Rep (Input id a) x)
-> (forall x. Rep (Input id a) x -> Input id a)
-> Generic (Input id a)
forall x. Rep (Input id a) x -> Input id a
forall x. Input id a -> Rep (Input id a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall id a x. Rep (Input id a) x -> Input id a
forall id a x. Input id a -> Rep (Input id a) x
$cfrom :: forall id a x. Input id a -> Rep (Input id a) x
from :: forall x. Input id a -> Rep (Input id a) x
$cto :: forall id a x. Rep (Input id a) x -> Input id a
to :: forall x. Rep (Input id a) x -> Input id a
Generic)
instance (ViewId id, FromParam id, ToParam id) => ViewId (Input id a) where
  type ViewState (Input id a) = ViewState id


{- | label for a 'field'
label :: Text -> View (Input id a) ()
-}
label :: View c () -> View c ()
label :: forall c. View c () -> View c ()
label = Text -> View c () -> View c ()
forall c. Text -> View c () -> View c ()
tag Text
"label"


-- | input for a 'field'
input :: forall id a. InputType -> View (Input id a) ()
input :: forall id a. InputType -> View (Input id a) ()
input InputType
ft = do
  Input id a
inp :: Input id a <- View (Input id a) (Input id a)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  Text -> View (Input id a) () -> View (Input id a) ()
forall c. Text -> View c () -> View c ()
tag Text
"input" (View (Input id a) () -> View (Input id a) ())
-> (Attributes (View (Input id a) () -> View (Input id a) ())
    -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> View (Input id a) ()
-> View (Input id a) ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Text
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"type" (InputType -> Text
forall {a}. IsString a => InputType -> a
inpType InputType
ft) (Attributes (View (Input id a) () -> View (Input id a) ())
 -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> (Attributes (View (Input id a) () -> View (Input id a) ())
    -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
name Input id a
inp.inputName.value (Attributes (View (Input id a) () -> View (Input id a) ())
 -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> (Attributes (View (Input id a) () -> View (Input id a) ())
    -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Text
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"autocomplete" (InputType -> Text
auto InputType
ft) (View (Input id a) () -> View (Input id a) ())
-> View (Input id a) () -> View (Input id a) ()
forall a b. (a -> b) -> a -> b
$ View (Input id a) ()
forall c. View c ()
none
 where
  inpType :: InputType -> a
inpType InputType
NewPassword = a
"password"
  inpType InputType
CurrentPassword = a
"password"
  inpType InputType
Number = a
"number"
  inpType InputType
Email = a
"email"
  inpType InputType
Search = a
"search"
  inpType InputType
_ = a
"text"

  auto :: InputType -> Text
  auto :: InputType -> Text
auto InputType
TextInput = Text
"off"
  auto InputType
inp = String -> Text
pack (String -> Text) -> (InputType -> String) -> InputType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
kebab ShowS -> (InputType -> String) -> InputType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputType -> String
forall a. Show a => a -> String
show (InputType -> Text) -> InputType -> Text
forall a b. (a -> b) -> a -> b
$ InputType
inp


checkbox :: forall id a. Bool -> View (Input id a) ()
checkbox :: forall id a. Bool -> View (Input id a) ()
checkbox Bool
isChecked = do
  Input id a
inp :: Input id a <- View (Input id a) (Input id a)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  Text -> View (Input id a) () -> View (Input id a) ()
forall c. Text -> View c () -> View c ()
tag Text
"input" (View (Input id a) () -> View (Input id a) ())
-> (Attributes (View (Input id a) () -> View (Input id a) ())
    -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> View (Input id a) ()
-> View (Input id a) ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Text
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"type" Text
"checkbox" (Attributes (View (Input id a) () -> View (Input id a) ())
 -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> (Attributes (View (Input id a) () -> View (Input id a) ())
    -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
name Input id a
inp.inputName.value (View (Input id a) () -> View (Input id a) ())
-> View (Input id a) () -> View (Input id a) ()
forall a b. (a -> b) -> a -> b
$ View (Input id a) ()
forall c. View c ()
none View (Input id a) ()
-> (Attributes (View (Input id a) ())
    -> Attributes (View (Input id a) ()))
-> View (Input id a) ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Bool
-> Attributes (View (Input id a) ())
-> Attributes (View (Input id a) ())
forall a. Attributable a => Bool -> Attributes a -> Attributes a
checked Bool
isChecked


-- NOTE: Radio is a special type of selection different from list type or
-- select. select or list input can be thought of one wrapper and multiple
-- options whereas radio is multiple wrappers with options. The context required
-- for radio is more than that required for select.
data Radio (id :: Type) (a :: Type) (opt :: Type) = Radio
  { forall id a opt. Radio id a opt -> id
id :: id
  , forall id a opt. Radio id a opt -> FieldName a
inputName :: FieldName a
  , forall id a opt. Radio id a opt -> opt
defaultOption :: opt
  }
  deriving ((forall x. Radio id a opt -> Rep (Radio id a opt) x)
-> (forall x. Rep (Radio id a opt) x -> Radio id a opt)
-> Generic (Radio id a opt)
forall x. Rep (Radio id a opt) x -> Radio id a opt
forall x. Radio id a opt -> Rep (Radio id a opt) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall id a opt x. Rep (Radio id a opt) x -> Radio id a opt
forall id a opt x. Radio id a opt -> Rep (Radio id a opt) x
$cfrom :: forall id a opt x. Radio id a opt -> Rep (Radio id a opt) x
from :: forall x. Radio id a opt -> Rep (Radio id a opt) x
$cto :: forall id a opt x. Rep (Radio id a opt) x -> Radio id a opt
to :: forall x. Rep (Radio id a opt) x -> Radio id a opt
Generic)
instance (FromParam id, ToParam id, FromParam a, ToParam a, ToParam opt, FromParam opt) => ViewId (Radio id a opt) where
  type ViewState (Radio id a opt) = ViewState id


radioGroup :: opt -> View (Radio id a opt) () -> View (Input id a) ()
radioGroup :: forall opt id a.
opt -> View (Radio id a opt) () -> View (Input id a) ()
radioGroup opt
defOpt = (Input id a -> Radio id a opt)
-> View (Radio id a opt) () -> View (Input id a) ()
forall ctx c.
(ViewState ctx ~ ViewState c) =>
(c -> ctx) -> View ctx () -> View c ()
runChildView (\(Input id a
inp :: Input id a) -> id -> FieldName a -> opt -> Radio id a opt
forall id a opt. id -> FieldName a -> opt -> Radio id a opt
Radio Input id a
inp.id Input id a
inp.inputName opt
defOpt)


radio :: forall id a opt. (Eq opt, ToParam opt) => opt -> View (Radio id a opt) ()
radio :: forall id a opt.
(Eq opt, ToParam opt) =>
opt -> View (Radio id a opt) ()
radio opt
val = do
  Radio id a opt
rd :: Radio id a opt <- View (Radio id a opt) (Radio id a opt)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  Text -> View (Radio id a opt) () -> View (Radio id a opt) ()
forall c. Text -> View c () -> View c ()
tag Text
"input"
    (View (Radio id a opt) () -> View (Radio id a opt) ())
-> (Attributes
      (View (Radio id a opt) () -> View (Radio id a opt) ())
    -> Attributes
         (View (Radio id a opt) () -> View (Radio id a opt) ()))
-> View (Radio id a opt) ()
-> View (Radio id a opt) ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Text
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"type" Text
"radio"
    (Attributes (View (Radio id a opt) () -> View (Radio id a opt) ())
 -> Attributes
      (View (Radio id a opt) () -> View (Radio id a opt) ()))
-> (Attributes
      (View (Radio id a opt) () -> View (Radio id a opt) ())
    -> Attributes
         (View (Radio id a opt) () -> View (Radio id a opt) ()))
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
name Radio id a opt
rd.inputName.value
    (Attributes (View (Radio id a opt) () -> View (Radio id a opt) ())
 -> Attributes
      (View (Radio id a opt) () -> View (Radio id a opt) ()))
-> (Attributes
      (View (Radio id a opt) () -> View (Radio id a opt) ())
    -> Attributes
         (View (Radio id a opt) () -> View (Radio id a opt) ()))
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
value (opt -> ParamValue
forall a. ToParam a => a -> ParamValue
toParam opt
val).value
    (Attributes (View (Radio id a opt) () -> View (Radio id a opt) ())
 -> Attributes
      (View (Radio id a opt) () -> View (Radio id a opt) ()))
-> (Attributes
      (View (Radio id a opt) () -> View (Radio id a opt) ())
    -> Attributes
         (View (Radio id a opt) () -> View (Radio id a opt) ()))
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
-> Attributes
     (View (Radio id a opt) () -> View (Radio id a opt) ())
forall a. Attributable a => Bool -> Attributes a -> Attributes a
checked (Radio id a opt
rd.defaultOption opt -> opt -> Bool
forall a. Eq a => a -> a -> Bool
== opt
val)
    (View (Radio id a opt) () -> View (Radio id a opt) ())
-> View (Radio id a opt) () -> View (Radio id a opt) ()
forall a b. (a -> b) -> a -> b
$ View (Radio id a opt) ()
forall c. View c ()
none


select :: forall opt id a. (Eq opt) => opt -> View (Option id opt) () -> View (Input id a) ()
select :: forall opt id a.
Eq opt =>
opt -> View (Option id opt) () -> View (Input id a) ()
select opt
defOpt View (Option id opt) ()
options = do
  Input id a
inp :: Input id a <- View (Input id a) (Input id a)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  Text -> View (Input id a) () -> View (Input id a) ()
forall c. Text -> View c () -> View c ()
tag Text
"select" (View (Input id a) () -> View (Input id a) ())
-> (Attributes (View (Input id a) () -> View (Input id a) ())
    -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> View (Input id a) ()
-> View (Input id a) ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
name Input id a
inp.inputName.value (View (Input id a) () -> View (Input id a) ())
-> View (Input id a) () -> View (Input id a) ()
forall a b. (a -> b) -> a -> b
$ (Input id a -> Option id opt)
-> View (Option id opt) () -> View (Input id a) ()
forall ctx c.
(ViewState ctx ~ ViewState c) =>
(c -> ctx) -> View ctx () -> View c ()
runChildView (\Input id a
_ -> id -> opt -> Option id opt
forall id opt. id -> opt -> Option id opt
Option Input id a
inp.id opt
defOpt) View (Option id opt) ()
options


-- | textarea for a 'field'
textarea :: forall id a. Maybe Text -> View (Input id a) ()
textarea :: forall id a. Maybe Text -> View (Input id a) ()
textarea Maybe Text
mDefaultText = do
  Input id a
inp :: Input id a <- View (Input id a) (Input id a)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  Text -> View (Input id a) () -> View (Input id a) ()
forall c. Text -> View c () -> View c ()
tag Text
"textarea" (View (Input id a) () -> View (Input id a) ())
-> (Attributes (View (Input id a) () -> View (Input id a) ())
    -> Attributes (View (Input id a) () -> View (Input id a) ()))
-> View (Input id a) ()
-> View (Input id a) ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Attributes (View (Input id a) () -> View (Input id a) ())
-> Attributes (View (Input id a) () -> View (Input id a) ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
name Input id a
inp.inputName.value (View (Input id a) () -> View (Input id a) ())
-> View (Input id a) () -> View (Input id a) ()
forall a b. (a -> b) -> a -> b
$ Text -> View (Input id a) ()
forall c. Text -> View c ()
text (Text -> View (Input id a) ()) -> Text -> View (Input id a) ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mDefaultText


------------------------------------------------------------------------------
-- VALIDATION
------------------------------------------------------------------------------

{- | Validation results for a 'Form'. See 'validate'

@
data UserForm f = UserForm
  { user :: Field f User
  , age :: Field f Int
  , pass1 :: Field f Text
  , pass2 :: Field f Text
  }
  deriving (Generic, FromFormF, GenFields Validated, GenFields FieldName)

validateForm :: UserForm Identity -> UserForm Validated
validateForm u =
  UserForm
    { user = validateUser u.user
    , age = validateAge u.age
    , pass1 = validatePass u.pass1 u.pass2
    , pass2 = NotInvalid
    }

validateAge :: Int -> Validated Int
validateAge a =
  validate (a < 20) \"User must be at least 20 years old\"
@
-}
data Validated a = Invalid Text | NotInvalid | Valid
  deriving (Int -> Validated a -> ShowS
[Validated a] -> ShowS
Validated a -> String
(Int -> Validated a -> ShowS)
-> (Validated a -> String)
-> ([Validated a] -> ShowS)
-> Show (Validated a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> Validated a -> ShowS
forall k (a :: k). [Validated a] -> ShowS
forall k (a :: k). Validated a -> String
$cshowsPrec :: forall k (a :: k). Int -> Validated a -> ShowS
showsPrec :: Int -> Validated a -> ShowS
$cshow :: forall k (a :: k). Validated a -> String
show :: Validated a -> String
$cshowList :: forall k (a :: k). [Validated a] -> ShowS
showList :: [Validated a] -> ShowS
Show)


instance Semigroup (Validated a) where
  Invalid Text
t <> :: Validated a -> Validated a -> Validated a
<> Validated a
_ = Text -> Validated a
forall {k} (a :: k). Text -> Validated a
Invalid Text
t
  Validated a
_ <> Invalid Text
t = Text -> Validated a
forall {k} (a :: k). Text -> Validated a
Invalid Text
t
  Validated a
Valid <> Validated a
_ = Validated a
forall {k} (a :: k). Validated a
Valid
  Validated a
_ <> Validated a
Valid = Validated a
forall {k} (a :: k). Validated a
Valid
  Validated a
a <> Validated a
_ = Validated a
a


instance Monoid (Validated a) where
  mempty :: Validated a
mempty = Validated a
forall {k} (a :: k). Validated a
NotInvalid


-- instance (FromParam a, ValidateField a) => FromParam (Validated a) where
--   parseParam inp = do
--     a <- parseParam @a inp
--     pure $ validateField a

isInvalid :: Validated a -> Bool
isInvalid :: forall {k} (a :: k). Validated a -> Bool
isInvalid (Invalid Text
_) = Bool
True
isInvalid Validated a
_ = Bool
False


-- class ValidateField a where
--   validateField :: a -> Validated a
--

-- class ValidationState (v :: Type -> Type) where
--   convert :: v a -> v b
--   isInvalid :: v a -> Bool
--
--
-- instance ValidationState Validated where
--   convert :: Validated a -> Validated b
--   convert (Invalid t) = Invalid t
--   convert NotInvalid = NotInvalid
--   convert Valid = Valid
--
--

{- Only shows if 'Validated' is 'Invalid'. See 'formFieldsWith'formform
@
@
-}
invalidText :: forall a id. Validated a -> View (Input id a) ()
invalidText :: forall a id. Validated a -> View (Input id a) ()
invalidText Validated a
v = do
  case Validated a
v of
    Invalid Text
t -> Text -> View (Input id a) ()
forall c. Text -> View c ()
text Text
t
    Validated a
_ -> View (Input id a) ()
forall c. View c ()
none


{- | specify a check for a 'Validation'

@
validateAge :: Int -> Validated Int
validateAge a =
  validate (a < 20) \"User must be at least 20 years old\"
@
-}
validate :: Bool -> Text -> Validated a
validate :: forall {k} (a :: k). Bool -> Text -> Validated a
validate Bool
True Text
t = Text -> Validated a
forall {k} (a :: k). Text -> Validated a
Invalid Text
t -- Validation [(inputName @a, Invalid t)]
validate Bool
False Text
_ = Validated a
forall {k} (a :: k). Validated a
NotInvalid -- Validation [(inputName @a, NotInvalid)]


{- | Field allows a Higher Kinded 'Form' to reuse the same selectors for form parsing, generating html forms, and validation

> Field Identity Text ~ Text
> Field Maybe Text ~ Maybe Text
-}
type family Field (context :: Type -> Type) a


-- type instance Field (FormField f) a = FormField f a
type instance Field Identity a = a
type instance Field FieldName a = FieldName a
type instance Field Validated a = Validated a
type instance Field Maybe a = Maybe a
type instance Field (Either String) a = Either String a


------------------------------------------------------------------------------
-- GENERIC FORM PARSE
------------------------------------------------------------------------------

class GFormParse f where
  gFormParse :: FE.Form -> Either String (f p)


instance (GFormParse f, GFormParse g) => GFormParse (f :*: g) where
  gFormParse :: forall (p :: k). Form -> Either String ((:*:) f g p)
gFormParse Form
f = do
    f p
a <- Form -> Either String (f p)
forall (p :: k). Form -> Either String (f p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either String (f p)
gFormParse Form
f
    g p
b <- Form -> Either String (g p)
forall (p :: k). Form -> Either String (g p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either String (f p)
gFormParse Form
f
    (:*:) f g p -> Either String ((:*:) f g p)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((:*:) f g p -> Either String ((:*:) f g p))
-> (:*:) f g p -> Either String ((:*:) f g p)
forall a b. (a -> b) -> a -> b
$ f p
a f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
b


instance (GFormParse f) => GFormParse (M1 D d f) where
  gFormParse :: forall (p :: k). Form -> Either String (M1 D d f p)
gFormParse Form
f = f p -> M1 D d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D d f p)
-> Either String (f p) -> Either String (M1 D d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form -> Either String (f p)
forall (p :: k). Form -> Either String (f p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either String (f p)
gFormParse Form
f


instance (GFormParse f) => GFormParse (M1 C c f) where
  gFormParse :: forall (p :: k). Form -> Either String (M1 C c f p)
gFormParse Form
f = f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p)
-> Either String (f p) -> Either String (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form -> Either String (f p)
forall (p :: k). Form -> Either String (f p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either String (f p)
gFormParse Form
f


-- TODO: need a bool instance?
-- TODO: need a Maybe a instance?
instance (Selector s, FromParam a) => GFormParse (M1 S s (K1 R a)) where
  -- these CANNOT be json encoded, they are encoded by the browser
  gFormParse :: forall (p :: k). Form -> Either String (M1 S s (K1 R a) p)
gFormParse Form
f = do
    let sel :: String
sel = M1 S s (K1 R (Any a)) Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s (K1 R (f a)) p
forall {k} {f :: * -> *} {p :: k}. M1 S s (K1 R (f a)) p
forall a. HasCallStack => a
undefined :: M1 S s (K1 R (f a)) p)
    Maybe Text
mt :: Maybe Text <- (Text -> String)
-> Either Text (Maybe Text) -> Either String (Maybe Text)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Either Text (Maybe Text) -> Either String (Maybe Text))
-> Either Text (Maybe Text) -> Either String (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Form -> Either Text (Maybe Text)
FE.lookupMaybe (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
sel) Form
f
    a
a <- ShowS -> Either String a -> Either String a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
err -> String
sel String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err) (Either String a -> Either String a)
-> Either String a -> Either String a
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Either String a
forall a. FromParam a => Maybe Text -> Either String a
decodeFormValue Maybe Text
mt
    M1 S s (K1 R a) p -> Either String (M1 S s (K1 R a) p)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (M1 S s (K1 R a) p -> Either String (M1 S s (K1 R a) p))
-> M1 S s (K1 R a) p -> Either String (M1 S s (K1 R a) p)
forall a b. (a -> b) -> a -> b
$ K1 R a p -> M1 S s (K1 R a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R a p -> M1 S s (K1 R a) p)
-> (a -> K1 R a p) -> a -> M1 S s (K1 R a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S s (K1 R a) p) -> a -> M1 S s (K1 R a) p
forall a b. (a -> b) -> a -> b
$ a
a


-- instance {-# OVERLAPPING #-} (Selector s, FromParam a) => GFormParse (M1 S s (K1 R (Maybe a))) where
--   gFormParse f = do
--     let sel = selName (undefined :: M1 S s (K1 R (f a)) p)
--     mt :: Maybe Text <- first cs $ FE.lookupMaybe (cs sel) f
--     ma :: Maybe a <- maybe (pure Nothing) (parseParam . decodeParam) mt
--     pure $ M1 . K1 $ ma

------------------------------------------------------------------------------
-- GENERIC GENERATE FIELDS
------------------------------------------------------------------------------

class GFieldsGen f where
  gFieldsGen :: f p


instance GFieldsGen U1 where
  gFieldsGen :: forall (p :: k). U1 p
gFieldsGen = U1 p
forall k (p :: k). U1 p
U1


instance (GFieldsGen f, GFieldsGen g) => GFieldsGen (f :*: g) where
  gFieldsGen :: forall (p :: k). (:*:) f g p
gFieldsGen = f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GFieldsGen f => f p
gFieldsGen f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
forall (p :: k). g p
forall {k} (f :: k -> *) (p :: k). GFieldsGen f => f p
gFieldsGen


-- instance (Selector s, GenField g a, Field f a ~ g a) => GFieldsGen (M1 S s (K1 R (g a))) where
--   gFieldsGen =
--     let sel = selName (undefined :: M1 S s (K1 R (f a)) p)
--      in M1 . K1 $ genField @g @a sel

instance (Selector s, GenField a) => GFieldsGen (M1 S s (K1 R a)) where
  gFieldsGen :: forall (p :: k). M1 S s (K1 R a) p
gFieldsGen =
    let sel :: String
sel = M1 S s (K1 R (Any a)) Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s (K1 R (f a)) p
forall {k} {f :: * -> *} {p :: k}. M1 S s (K1 R (f a)) p
forall a. HasCallStack => a
undefined :: M1 S s (K1 R (f a)) p)
     in K1 R a p -> M1 S s (K1 R a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R a p -> M1 S s (K1 R a) p)
-> (a -> K1 R a p) -> a -> M1 S s (K1 R a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S s (K1 R a) p) -> a -> M1 S s (K1 R a) p
forall a b. (a -> b) -> a -> b
$ forall a. GenField a => String -> a
genField @a String
sel


instance (GFieldsGen f) => GFieldsGen (M1 D d f) where
  gFieldsGen :: forall (p :: k). M1 D d f p
gFieldsGen = f p -> M1 D d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GFieldsGen f => f p
gFieldsGen


instance (GFieldsGen f) => GFieldsGen (M1 C c f) where
  gFieldsGen :: forall (p :: k). M1 C c f p
gFieldsGen = f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GFieldsGen f => f p
gFieldsGen

------------------------------------------------------------------------------
-- GMerge - combine two records with the same structure
------------------------------------------------------------------------------

-- class GMerge ra rb rc where
--   gMerge :: ra p -> rb p -> rc p
--
--
-- instance (GMerge ra0 rb0 rc0, GMerge ra1 rb1 rc1) => GMerge (ra0 :*: ra1) (rb0 :*: rb1) (rc0 :*: rc1) where
--   gMerge (a0 :*: a1) (b0 :*: b1) = gMerge a0 b0 :*: gMerge a1 b1
--
--
-- instance (GMerge ra rb rc) => GMerge (M1 D d ra) (M1 D d rb) (M1 D d rc) where
--   gMerge (M1 fa) (M1 fb) = M1 $ gMerge fa fb
--
--
-- instance (GMerge ra rb rc) => GMerge (M1 C d ra) (M1 C d rb) (M1 C d rc) where
--   gMerge (M1 fa) (M1 fb) = M1 $ gMerge fa fb
--
--
-- instance (Selector s, MergeField a b c) => GMerge (M1 S s (K1 R a)) (M1 S s (K1 R b)) (M1 S s (K1 R c)) where
--   gMerge (M1 (K1 a)) (M1 (K1 b)) = M1 . K1 $ mergeField a b
--
--
-- class MergeField a b c where
--   mergeField :: a -> b -> c

-- instance MergeField (FieldName a) (Validated a) (FormField Validated a) where
--   mergeField = FormField

------------------------------------------------------------------------------
-- GConvert - combine two records with the same structure
------------------------------------------------------------------------------

-- class ConvertFields a where
--   convertFields :: (FromSelector f g) => a f -> a g
--   default convertFields :: (Generic (a f), Generic (a g), GConvert (Rep (a f)) (Rep (a g))) => a f -> a g
--   convertFields x = to $ gConvert (from x)
--
-- class GConvert ra rc where
--   gConvert :: ra p -> rc p
--
--
-- instance (GConvert ra0 rc0, GConvert ra1 rc1) => GConvert (ra0 :*: ra1) (rc0 :*: rc1) where
--   gConvert (a0 :*: a1) = gConvert a0 :*: gConvert a1
--
--
-- instance (GConvert ra rc) => GConvert (M1 D d ra) (M1 D d rc) where
--   gConvert (M1 fa) = M1 $ gConvert fa
--
--
-- instance (GConvert ra rc) => GConvert (M1 C d ra) (M1 C d rc) where
--   gConvert (M1 fa) = M1 $ gConvert fa
--
--
-- instance (Selector s, GenFieldFrom f g a, Field g a ~ g a) => GConvert (M1 S s (K1 R (f a))) (M1 S s (K1 R (g a))) where
--   gConvert (M1 (K1 inp)) =
--     let sel = selName (undefined :: M1 S s (K1 R (f a)) p)
--      in M1 . K1 $ genFieldFrom @f @g sel inp
--
--
-- class GenFieldFrom inp f a where
--   genFieldFrom :: String -> inp a -> Field f a
--
--
-- -- instance GenFieldFrom Validated (FormField Validated) a where
-- --   genFieldFrom s = FormField (FieldName $ pack s)
--
-- instance GenFieldFrom val (FormField val) a where
--   genFieldFrom s = FormField (FieldName $ pack s)

------------------------------------------------------------------------------

-- class GCollect ra v where
--   gCollect :: ra p -> [v ()]
--
--
-- instance GCollect U1 v where
--   gCollect _ = []
--
--
-- instance (GCollect f v, GCollect g v) => GCollect (f :*: g) v where
--   gCollect (a :*: b) = gCollect a <> gCollect b
--
--
-- instance (Selector s, ValidationState v) => GCollect (M1 S s (K1 R (v a))) v where
--   gCollect (M1 (K1 val)) = [convert val]
--
--
-- instance (GCollect f v) => GCollect (M1 D d f) v where
--   gCollect (M1 f) = gCollect f
--
--
-- instance (GCollect f v) => GCollect (M1 C c f) v where
--   gCollect (M1 f) = gCollect f