{-# LANGUAGE DefaultSignatures #-}

module Web.Hyperbole.Forms where

import Data.Functor.Identity (Identity)
import Data.Kind (Type)
import Data.Text
import Effectful
import GHC.Generics
import Text.Casing (kebab)
import Web.FormUrlEncoded qualified as FE
import Web.Hyperbole.Effect
import Web.Hyperbole.HyperView (HyperView (..), Param (..), dataTarget)
import Web.Internal.FormUrlEncoded (GFromForm, defaultFormOptions, genericFromForm)
import Web.View hiding (form, input)


-- | The only time we can use Fields is inside a form
newtype FormFields f id = FormFields id
  deriving newtype (Int -> FormFields f id -> ShowS
[FormFields f id] -> ShowS
FormFields f id -> String
(Int -> FormFields f id -> ShowS)
-> (FormFields f id -> String)
-> ([FormFields f id] -> ShowS)
-> Show (FormFields f id)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (f :: k) id. Show id => Int -> FormFields f id -> ShowS
forall k (f :: k) id. Show id => [FormFields f id] -> ShowS
forall k (f :: k) id. Show id => FormFields f id -> String
$cshowsPrec :: forall k (f :: k) id. Show id => Int -> FormFields f id -> ShowS
showsPrec :: Int -> FormFields f id -> ShowS
$cshow :: forall k (f :: k) id. Show id => FormFields f id -> String
show :: FormFields f id -> String
$cshowList :: forall k (f :: k) id. Show id => [FormFields f id] -> ShowS
showList :: [FormFields f id] -> ShowS
Show)


instance (Param id, Show id) => Param (FormFields f id) where
  parseParam :: Text -> Maybe (FormFields f id)
parseParam Text
t = id -> FormFields f id
forall {k} (f :: k) id. id -> FormFields f id
FormFields (id -> FormFields f id) -> Maybe id -> Maybe (FormFields f id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe id
forall a. Param a => Text -> Maybe a
parseParam Text
t
  toParam :: FormFields f id -> Text
toParam (FormFields id
i) = id -> Text
forall a. Param a => a -> Text
toParam id
i


instance (HyperView id, Show id) => HyperView (FormFields f id) where
  type Action (FormFields f id) = Action id


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


data Label a


data Input a = Input


newtype InputName = InputName Text


field :: Mod -> View (Input id) () -> View (FormFields form id) ()
field :: forall {k} id (form :: k).
Mod -> View (Input id) () -> View (FormFields form id) ()
field Mod
f View (Input id) ()
cnt =
  Text
-> Mod
-> View (FormFields form id) ()
-> View (FormFields form id) ()
forall c. Text -> Mod -> View c () -> View c ()
tag Text
"label" (Mod
f Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod
flexCol)
    (View (FormFields form id) () -> View (FormFields form id) ())
-> View (FormFields form id) () -> View (FormFields form id) ()
forall a b. (a -> b) -> a -> b
$ Input id -> View (Input id) () -> View (FormFields form id) ()
forall context c. context -> View context () -> View c ()
addContext Input id
forall {k} (a :: k). Input a
Input View (Input id) ()
cnt


label :: Text -> View (Input id) ()
label :: forall {k} (id :: k). Text -> View (Input id) ()
label = Text -> View (Input id) ()
forall c. Text -> View c ()
text


input :: FieldInput -> Mod -> InputName -> View (Input id) ()
input :: forall {k} (id :: k).
FieldInput -> Mod -> InputName -> View (Input id) ()
input FieldInput
fi Mod
f (InputName Text
n) = Text -> Mod -> View (Input id) () -> View (Input id) ()
forall c. Text -> Mod -> View c () -> View c ()
tag Text
"input" (Mod
f Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Mod
name Text
n Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Mod
att Text
"type" (FieldInput -> Text
forall {a}. IsString a => FieldInput -> a
typ FieldInput
fi) Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Mod
att Text
"autocomplete" (FieldInput -> Text
auto FieldInput
fi)) View (Input id) ()
forall c. View c ()
none
 where
  typ :: FieldInput -> a
typ FieldInput
NewPassword = a
"password"
  typ FieldInput
CurrentPassword = a
"password"
  typ FieldInput
Number = a
"number"
  typ FieldInput
Email = a
"email"
  typ FieldInput
Search = a
"search"
  typ FieldInput
_ = a
"text"

  auto :: FieldInput -> Text
  auto :: FieldInput -> Text
auto = String -> Text
pack (String -> Text) -> (FieldInput -> String) -> FieldInput -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
kebab ShowS -> (FieldInput -> String) -> FieldInput -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInput -> String
forall a. Show a => a -> String
show


form :: forall form id. (Form form, HyperView id) => Action id -> Mod -> (form Label -> View (FormFields form id) ()) -> View id ()
form :: forall (form :: (* -> *) -> *) id.
(Form form, HyperView id) =>
Action id
-> Mod
-> (form Label -> View (FormFields form id) ())
-> View id ()
form Action id
a Mod
f form Label -> View (FormFields form id) ()
fcnt = do
  id
vid <- View id id
forall context. View context context
context
  let frm :: form Label
frm = form Label
forall (form :: (* -> *) -> *). Form form => form Label
formLabels :: form Label
  let cnt :: View (FormFields form id) ()
cnt = form Label -> View (FormFields form id) ()
fcnt form Label
frm
  Text -> Mod -> View id () -> View id ()
forall c. Text -> Mod -> View c () -> View c ()
tag Text
"form" (Action id -> Mod
forall a. Param a => a -> Mod
onSubmit Action id
a Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. id -> Mod
forall a. Param a => a -> Mod
dataTarget id
vid Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod
f Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod
flexCol) (View id () -> View id ()) -> View id () -> View id ()
forall a b. (a -> b) -> a -> b
$ FormFields form id -> View (FormFields form id) () -> View id ()
forall context c. context -> View context () -> View c ()
addContext (id -> FormFields form id
forall {k} (f :: k) id. id -> FormFields f id
FormFields id
vid) View (FormFields form id) ()
cnt
 where
  onSubmit :: (Param a) => a -> Mod
  onSubmit :: forall a. Param a => a -> Mod
onSubmit = Text -> Text -> Mod
att Text
"data-on-submit" (Text -> Mod) -> (a -> Text) -> a -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Param a => a -> Text
toParam


submit :: Mod -> View (FormFields form id) () -> View (FormFields form id) ()
submit :: forall {k} (form :: k) id.
Mod -> View (FormFields form id) () -> View (FormFields form id) ()
submit Mod
f = Text
-> Mod
-> View (FormFields form id) ()
-> View (FormFields form id) ()
forall c. Text -> Mod -> View c () -> View c ()
tag Text
"button" (Text -> Text -> Mod
att Text
"type" Text
"submit" Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod
f)


parseForm :: forall form es. (Form form, Hyperbole :> es) => Eff es (form Identity)
parseForm :: forall (form :: (* -> *) -> *) (es :: [Effect]).
(Form form, Hyperbole :> es) =>
Eff es (form Identity)
parseForm = do
  (Form
f :: FE.Form) <- Eff es Form
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Form
formData
  let ef :: Either Text (form Identity)
ef = Form -> Either Text (form Identity)
forall (form :: (* -> *) -> *).
Form form =>
Form -> Either Text (form Identity)
fromForm Form
f :: Either Text (form Identity)
  (Text -> Eff es (form Identity))
-> (form Identity -> Eff es (form Identity))
-> Either Text (form Identity)
-> Eff es (form Identity)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Eff es (form Identity)
forall (es :: [Effect]) a. (Hyperbole :> es) => Text -> Eff es a
parseError form Identity -> Eff es (form Identity)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Text (form Identity)
ef


class Form (form :: (Type -> Type) -> Type) where
  formLabels :: form Label
  default formLabels :: (Generic (form Label), GFormLabels (Rep (form Label))) => form Label
  formLabels = Rep (form Label) Any -> form Label
forall a x. Generic a => Rep a x -> a
forall x. Rep (form Label) x -> form Label
to Rep (form Label) Any
forall p. Rep (form Label) p
forall {k} (f :: k -> *) (p :: k). GFormLabels f => f p
gFormLabels


  fromForm :: FE.Form -> Either Text (form Identity)
  default fromForm :: (Generic (form Identity), GFromForm (form Identity) (Rep (form Identity))) => FE.Form -> Either Text (form Identity)
  fromForm = FormOptions -> Form -> Either Text (form Identity)
forall a.
(Generic a, GFromForm a (Rep a)) =>
FormOptions -> Form -> Either Text a
genericFromForm FormOptions
defaultFormOptions


type family Field (context :: Type -> Type) a
type instance Field Identity a = a
type instance Field Label a = InputName


-- | Automatically derive labels from form field names
class GFormLabels f where
  gFormLabels :: f p


instance GFormLabels U1 where
  gFormLabels :: forall (p :: k). U1 p
gFormLabels = U1 p
forall k (p :: k). U1 p
U1


instance (GFormLabels f, GFormLabels g) => GFormLabels (f :*: g) where
  gFormLabels :: forall (p :: k). (:*:) f g p
gFormLabels = f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GFormLabels f => f p
gFormLabels 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). GFormLabels f => f p
gFormLabels


instance (Selector s) => GFormLabels (M1 S s (K1 R InputName)) where
  gFormLabels :: forall (p :: k). M1 S s (K1 R InputName) p
gFormLabels = K1 R InputName p -> M1 S s (K1 R InputName) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R InputName p -> M1 S s (K1 R InputName) p)
-> (InputName -> K1 R InputName p)
-> InputName
-> M1 S s (K1 R InputName) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputName -> K1 R InputName p
forall k i c (p :: k). c -> K1 i c p
K1 (InputName -> M1 S s (K1 R InputName) p)
-> InputName -> M1 S s (K1 R InputName) p
forall a b. (a -> b) -> a -> b
$ Text -> InputName
InputName (Text -> InputName) -> Text -> InputName
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (M1 S s (K1 R Text) 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 Text) p
forall {k} {p :: k}. M1 S s (K1 R Text) p
forall a. HasCallStack => a
undefined :: M1 S s (K1 R Text) p))


instance (GFormLabels f) => GFormLabels (M1 D d f) where
  gFormLabels :: forall (p :: k). M1 D d f p
gFormLabels = 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). GFormLabels f => f p
gFormLabels


instance (GFormLabels f) => GFormLabels (M1 C c f) where
  gFormLabels :: forall (p :: k). M1 C c f p
gFormLabels = 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). GFormLabels f => f p
gFormLabels