{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
module Web.Hyperbole.Forms
( FormFields (..)
, InputType (..)
, Label
, Invalid
, Input (..)
, field
, label
, input
, form
, placeholder
, submit
, parseForm
, formField
, Form (..)
, defaultFormOptions
, FormOptions (..)
, genericFromForm
, Validation (..)
, FormField (..)
, lookupInvalid
, invalidStyle
, invalidText
, validate
, validation
, FromHttpApiData
, Generic
)
where
import Data.Functor.Identity (Identity)
import Data.Kind (Type)
import Data.Maybe (catMaybes)
import Data.Text
import Effectful
import GHC.Generics
import Text.Casing (kebab)
import Web.FormUrlEncoded qualified as FE
import Web.HttpApiData (FromHttpApiData (..))
import Web.Hyperbole.Effect
import Web.Hyperbole.HyperView (HyperView (..), Param (..), dataTarget)
import Web.Internal.FormUrlEncoded (FormOptions (..), GFromForm, defaultFormOptions, genericFromForm)
import Web.View hiding (form, input, label)
data FormFields id = FormFields id Validation
instance (Param id) => Param (FormFields id) where
parseParam :: Text -> Maybe (FormFields id)
parseParam Text
t = do
id
i <- Text -> Maybe id
forall a. Param a => Text -> Maybe a
parseParam Text
t
FormFields id -> Maybe (FormFields id)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormFields id -> Maybe (FormFields id))
-> FormFields id -> Maybe (FormFields id)
forall a b. (a -> b) -> a -> b
$ id -> Validation -> FormFields id
forall id. id -> Validation -> FormFields id
FormFields id
i Validation
forall a. Monoid a => a
mempty
toParam :: FormFields id -> Text
toParam (FormFields id
i Validation
_) = id -> Text
forall a. Param a => a -> Text
toParam id
i
instance (HyperView id, Param id) => HyperView (FormFields id) where
type Action (FormFields id) = Action id
data InputType
=
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)
newtype Validation = Validation [(Text, Text)]
deriving newtype (NonEmpty Validation -> Validation
Validation -> Validation -> Validation
(Validation -> Validation -> Validation)
-> (NonEmpty Validation -> Validation)
-> (forall b. Integral b => b -> Validation -> Validation)
-> Semigroup Validation
forall b. Integral b => b -> Validation -> Validation
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Validation -> Validation -> Validation
<> :: Validation -> Validation -> Validation
$csconcat :: NonEmpty Validation -> Validation
sconcat :: NonEmpty Validation -> Validation
$cstimes :: forall b. Integral b => b -> Validation -> Validation
stimes :: forall b. Integral b => b -> Validation -> Validation
Semigroup, Semigroup Validation
Validation
Semigroup Validation =>
Validation
-> (Validation -> Validation -> Validation)
-> ([Validation] -> Validation)
-> Monoid Validation
[Validation] -> Validation
Validation -> Validation -> Validation
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Validation
mempty :: Validation
$cmappend :: Validation -> Validation -> Validation
mappend :: Validation -> Validation -> Validation
$cmconcat :: [Validation] -> Validation
mconcat :: [Validation] -> Validation
Monoid)
validation :: [Maybe (Text, Text)] -> Validation
validation :: [Maybe (Text, Text)] -> Validation
validation = [(Text, Text)] -> Validation
Validation ([(Text, Text)] -> Validation)
-> ([Maybe (Text, Text)] -> [(Text, Text)])
-> [Maybe (Text, Text)]
-> Validation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, Text)] -> [(Text, Text)]
forall a. [Maybe a] -> [a]
catMaybes
invalidStyle :: forall a. (FormField a) => Mod -> Validation -> Mod
invalidStyle :: forall a. FormField a => Mod -> Validation -> Mod
invalidStyle Mod
f Validation
errs =
case forall a. FormField a => Validation -> Maybe Text
lookupInvalid @a Validation
errs of
Maybe Text
Nothing -> Mod
forall a. a -> a
id
Just Text
_ -> Mod
f
lookupInvalid :: forall a. (FormField a) => Validation -> Maybe Text
lookupInvalid :: forall a. FormField a => Validation -> Maybe Text
lookupInvalid (Validation [(Text, Text)]
es) = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall a. FormField a => Text
inputName @a) [(Text, Text)]
es
invalidText :: forall a id. (FormField a) => View (Input id a) ()
invalidText :: forall {k} a (id :: k). FormField a => View (Input id a) ()
invalidText = do
Input Text
_ Validation
v <- View (Input id a) (Input id a)
forall context. View context context
context
View (Input id a) ()
-> (Text -> View (Input id a) ())
-> Maybe Text
-> View (Input id a) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe View (Input id a) ()
forall c. View c ()
none Text -> View (Input id a) ()
forall c. Text -> View c ()
text (Maybe Text -> View (Input id a) ())
-> Maybe Text -> View (Input id a) ()
forall a b. (a -> b) -> a -> b
$ forall a. FormField a => Validation -> Maybe Text
lookupInvalid @a Validation
v
validate :: forall a. (FormField a) => Bool -> Text -> Maybe (Text, Text)
validate :: forall a. FormField a => Bool -> Text -> Maybe (Text, Text)
validate Bool
True Text
t = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (forall a. FormField a => Text
inputName @a, Text
t)
validate Bool
False Text
_ = Maybe (Text, Text)
forall a. Maybe a
Nothing
data Label a
data Invalid a
data Input id a = Input Text Validation
field :: forall a id. (FormField a) => Mod -> Mod -> View (Input id a) () -> View (FormFields id) ()
field :: forall a id.
FormField a =>
Mod -> Mod -> View (Input id a) () -> View (FormFields id) ()
field Mod
f Mod
inv View (Input id a) ()
cnt = do
let n :: Text
n = forall a. FormField a => Text
inputName @a
FormFields id
_ Validation
v <- View (FormFields id) (FormFields id)
forall context. View context context
context
Text -> Mod -> View (FormFields id) () -> View (FormFields 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 Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FormField a => Mod -> Validation -> Mod
invalidStyle @a Mod
inv Validation
v) (View (FormFields id) () -> View (FormFields id) ())
-> View (FormFields id) () -> View (FormFields id) ()
forall a b. (a -> b) -> a -> b
$
Input id a -> View (Input id a) () -> View (FormFields id) ()
forall context c. context -> View context () -> View c ()
addContext (Text -> Validation -> Input id a
forall {k} {k} (id :: k) (a :: k). Text -> Validation -> Input id a
Input Text
n Validation
v) View (Input id a) ()
cnt
label :: Text -> View (Input id a) ()
label :: forall {k} {k} (id :: k) (a :: k). Text -> View (Input id a) ()
label = Text -> View (Input id a) ()
forall c. Text -> View c ()
text
input :: InputType -> Mod -> View (Input id a) ()
input :: forall {k} {k} (id :: k) (a :: k).
InputType -> Mod -> View (Input id a) ()
input InputType
ft Mod
f = do
Input Text
nm Validation
_ <- View (Input id a) (Input id a)
forall context. View context context
context
Text -> Mod -> View (Input id a) () -> View (Input id a) ()
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
nm Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Mod
att Text
"type" (InputType -> Text
forall {a}. IsString a => InputType -> a
inpType InputType
ft) Mod -> Mod -> Mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Mod
att Text
"autocomplete" (InputType -> Text
auto InputType
ft)) 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 = 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
placeholder :: Text -> Mod
placeholder :: Text -> Mod
placeholder = Text -> Text -> Mod
att Text
"placeholder"
form :: forall id. (HyperView id) => Action id -> Validation -> Mod -> View (FormFields id) () -> View id ()
form :: forall id.
HyperView id =>
Action id
-> Validation -> Mod -> View (FormFields id) () -> View id ()
form Action id
a Validation
v Mod
f View (FormFields id) ()
cnt = do
id
vid <- View id id
forall context. View context context
context
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 id -> View (FormFields id) () -> View id ()
forall context c. context -> View context () -> View c ()
addContext (id -> Validation -> FormFields id
forall id. id -> Validation -> FormFields id
FormFields id
vid Validation
v) View (FormFields 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 id) () -> View (FormFields id) ()
submit :: forall id.
Mod -> View (FormFields id) () -> View (FormFields id) ()
submit Mod
f = Text -> Mod -> View (FormFields id) () -> View (FormFields 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)
type family Field' (context :: Type -> Type) a
type instance Field' Identity a = a
type instance Field' Label a = Text
type instance Field' Invalid a = Maybe Text
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 <- 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
formField :: forall a es. (FormField a, Hyperbole :> es) => Eff es a
formField :: forall a (es :: [Effect]).
(FormField a, Hyperbole :> es) =>
Eff es a
formField = do
Form
f <- Eff es Form
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Form
formData
case Text -> Form -> Either Text a
forall a. FormField a => Text -> Form -> Either Text a
fieldParse (forall a. FormField a => Text
inputName @a) Form
f of
Left Text
e -> Text -> Eff es a
forall (es :: [Effect]) a. (Hyperbole :> es) => Text -> Eff es a
parseError Text
e
Right a
a -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
class Form (form :: (Type -> Type) -> Type) where
formLabels :: form Label
default formLabels :: (Generic (form Label), GForm (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). GForm f => f p
gForm
formInvalid :: form Invalid
default formInvalid :: (Generic (form Invalid), GForm (Rep (form Invalid))) => form Invalid
formInvalid = Rep (form Invalid) Any -> form Invalid
forall a x. Generic a => Rep a x -> a
forall x. Rep (form Invalid) x -> form Invalid
to Rep (form Invalid) Any
forall p. Rep (form Invalid) p
forall {k} (f :: k -> *) (p :: k). GForm f => f p
gForm
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
class GForm f where
gForm :: f p
instance GForm U1 where
gForm :: forall (p :: k). U1 p
gForm = U1 p
forall k (p :: k). U1 p
U1
instance (GForm f, GForm g) => GForm (f :*: g) where
gForm :: forall (p :: k). (:*:) f g p
gForm = f p
forall (p :: k). f p
forall {k} (f :: k -> *) (p :: k). GForm f => f p
gForm 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). GForm f => f p
gForm
instance (GForm f) => GForm (M1 D d f) where
gForm :: forall (p :: k). M1 D d f p
gForm = 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). GForm f => f p
gForm
instance (GForm f) => GForm (M1 C c f) where
gForm :: forall (p :: k). M1 C c f p
gForm = 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). GForm f => f p
gForm
instance (Selector s) => GForm (M1 S s (K1 R Text)) where
gForm :: forall (p :: k). M1 S s (K1 R Text) p
gForm = K1 R Text p -> M1 S s (K1 R Text) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R Text p -> M1 S s (K1 R Text) p)
-> (Text -> K1 R Text p) -> Text -> M1 S s (K1 R Text) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> K1 R Text p
forall k i c (p :: k). c -> K1 i c p
K1 (Text -> M1 S s (K1 R Text) p) -> Text -> M1 S s (K1 R Text) p
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 GForm (M1 S s (K1 R (Maybe Text))) where
gForm :: forall (p :: k). M1 S s (K1 R (Maybe Text)) p
gForm = K1 R (Maybe Text) p -> M1 S s (K1 R (Maybe Text)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (Maybe Text) p -> M1 S s (K1 R (Maybe Text)) p)
-> (Maybe Text -> K1 R (Maybe Text) p)
-> Maybe Text
-> M1 S s (K1 R (Maybe Text)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> K1 R (Maybe Text) p
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe Text -> M1 S s (K1 R (Maybe Text)) p)
-> Maybe Text -> M1 S s (K1 R (Maybe Text)) p
forall a b. (a -> b) -> a -> b
$ Maybe Text
forall a. Maybe a
Nothing
class FormField a where
inputName :: Text
default inputName :: (Generic a, GDataName (Rep a)) => Text
inputName = Rep a Any -> Text
forall p. Rep a p -> Text
forall {k} (f :: k -> *) (p :: k). GDataName f => f p -> Text
gDataName (a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a
forall a. HasCallStack => a
undefined :: a))
fieldParse :: Text -> FE.Form -> Either Text a
default fieldParse :: (Generic a, GFieldParse (Rep a)) => Text -> FE.Form -> Either Text a
fieldParse Text
t Form
f = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> Either Text (Rep a Any) -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Form -> Either Text (Rep a Any)
forall p. Text -> Form -> Either Text (Rep a p)
forall {k} (f :: k -> *) (p :: k).
GFieldParse f =>
Text -> Form -> Either Text (f p)
gFieldParse Text
t Form
f
class GDataName f where
gDataName :: f p -> Text
instance (Datatype d) => GDataName (M1 D d (M1 C c f)) where
gDataName :: forall (p :: k). M1 D d (M1 C c f) p -> Text
gDataName M1 D d (M1 C c f) p
m1 = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 D d (M1 C c f) p -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t d f a -> String
datatypeName M1 D d (M1 C c f) p
m1
class GFieldParse f where
gFieldParse :: Text -> FE.Form -> Either Text (f p)
instance (GFieldParse f) => GFieldParse (M1 D d f) where
gFieldParse :: forall (p :: k). Text -> Form -> Either Text (M1 D d f p)
gFieldParse Text
t 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 Text (f p) -> Either Text (M1 D d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Form -> Either Text (f p)
forall (p :: k). Text -> Form -> Either Text (f p)
forall {k} (f :: k -> *) (p :: k).
GFieldParse f =>
Text -> Form -> Either Text (f p)
gFieldParse Text
t Form
f
instance (GFieldParse f) => GFieldParse (M1 C c f) where
gFieldParse :: forall (p :: k). Text -> Form -> Either Text (M1 C c f p)
gFieldParse Text
t 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 Text (f p) -> Either Text (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Form -> Either Text (f p)
forall (p :: k). Text -> Form -> Either Text (f p)
forall {k} (f :: k -> *) (p :: k).
GFieldParse f =>
Text -> Form -> Either Text (f p)
gFieldParse Text
t Form
f
instance (GFieldParse f) => GFieldParse (M1 S s f) where
gFieldParse :: forall (p :: k). Text -> Form -> Either Text (M1 S s f p)
gFieldParse Text
t Form
f = f p -> M1 S s f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 S s f p)
-> Either Text (f p) -> Either Text (M1 S s f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Form -> Either Text (f p)
forall (p :: k). Text -> Form -> Either Text (f p)
forall {k} (f :: k -> *) (p :: k).
GFieldParse f =>
Text -> Form -> Either Text (f p)
gFieldParse Text
t Form
f
instance (FromHttpApiData a) => GFieldParse (K1 R a) where
gFieldParse :: forall (p :: k). Text -> Form -> Either Text (K1 R a p)
gFieldParse Text
t Form
f = a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 R a p) -> Either Text a -> Either Text (K1 R a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Form -> Either Text a
forall v. FromHttpApiData v => Text -> Form -> Either Text v
FE.parseUnique Text
t Form
f