{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}

module Web.Hyperbole.View.Forms
  ( FormFields (..)
  , InputType (..)
  , FieldName
  , Invalid
  , Input (..)
  , field
  , label
  , input
  , form
  , textarea
  , placeholder
  , submit
  , formData
  , Form (..)
  , formFields
  , formFieldsWith
  , Field
  , defaultFormOptions
  , FormOptions (..)
  , Validated (..)
  , FormField (..)
  , fieldValid
  , anyInvalid
  , invalidText
  , validate
  , Identity

    -- * Re-exports
  , FromQueryData
  , Generic
  , GenFields (..)
  , GenField (..)
  )
where

import Data.Function ((&))
import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import Debug.Trace
import Effectful
import GHC.Generics
import Text.Casing (kebab)
import Web.FormUrlEncoded (FormOptions (..), defaultFormOptions, parseUnique)
import Web.FormUrlEncoded qualified as FE
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.QueryData (FromQueryData (..))
import Web.Hyperbole.Effect.Request
import Web.Hyperbole.Effect.Respond (parseError)
import Web.Hyperbole.HyperView
import Web.Hyperbole.View.Event (onSubmit)
import Web.View hiding (form, input, label)
import Web.View.Style (addClass, cls, prop)


-- | The only time we can use Fields is inside a form
data FormFields id = FormFields id


data FormField v a = FormField
  { forall {k} (v :: k -> *) (a :: k). FormField v a -> FieldName a
fieldName :: FieldName a
  , forall {k} (v :: k -> *) (a :: k). FormField v a -> v a
validated :: v a
  }
  deriving (Int -> FormField v a -> ShowS
[FormField v a] -> ShowS
FormField v a -> String
(Int -> FormField v a -> ShowS)
-> (FormField v a -> String)
-> ([FormField v a] -> ShowS)
-> Show (FormField v a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (v :: k -> *) (a :: k).
Show (v a) =>
Int -> FormField v a -> ShowS
forall k (v :: k -> *) (a :: k).
Show (v a) =>
[FormField v a] -> ShowS
forall k (v :: k -> *) (a :: k).
Show (v a) =>
FormField v a -> String
$cshowsPrec :: forall k (v :: k -> *) (a :: k).
Show (v a) =>
Int -> FormField v a -> ShowS
showsPrec :: Int -> FormField v a -> ShowS
$cshow :: forall k (v :: k -> *) (a :: k).
Show (v a) =>
FormField v a -> String
show :: FormField v a -> String
$cshowList :: forall k (v :: k -> *) (a :: k).
Show (v a) =>
[FormField v a] -> ShowS
showList :: [FormField v a] -> ShowS
Show)


-- instance Show (v a) => Show (FormField v) where
--   show f = "Form Field"

-- instance (ViewId id) => ViewId (FormFields id v fs) where
--   parseViewId t = do
--     i <- parseViewId t
--     pure $ FormFields i lbls mempty
--   toViewId (FormFields i _ _) = toViewId i
--
--
-- instance (HyperView id, ViewId id) => HyperView (FormFields id v fs) where
--   type Action (FormFields id v fs) = Action id

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


{- | Validation results for a 'form'

@
data UserForm f = UserForm
  { username :: Field f
  , age :: Field f Int
  }
  deriving (Generic)


validateUsername :: Username -> Validated Username
validateUsername (Username u) =
  mconcat
    [ validate (T.elem ' ' u) "Username must not contain spaces"
    , validate (T.length u < 4) "Username must be at least 4 chars"
    , if u == "admin" || u == "guest"
        then Invalid "Username is already in use"
        else Valid
    ]

formAction :: ('Hyperbole' :> es, 'UserDB' :> es) => FormView -> FormAction -> 'Eff' es ('View' FormView ())
formAction _ SignUp = do
  u <- 'formField' \@Age

  case validateUser u a of
    'Validation' [] -> successView
    errs -> userForm v
@
-}

-- would be easier if you pass in your own data. Right now everything is indexed by type
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


-- type Validation = Validation' Validated
--
--
-- newtype Validation' validated a = Validation [(Text, validated ())]
--   deriving newtype (Semigroup, Monoid)

-- instance (Show (v ())) => Show (Validation' v fs) whervalid   show (Validation v) = show v
--
--
-- validation :: forall a fs v. (FormField a, Elem a fs, ValidationState v, Monoid (v a)) => Validation' v fs -> v a
-- validation (Validation vs) = mconcat $ fmap (convert . snd) $ filter ((== inputName @a) . fst) vs

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 :: forall {k} {k} (a :: k) (b :: k). Validated a -> Validated b
convert (Invalid Text
t) = Text -> Validated b
forall {k} (a :: k). Text -> Validated a
Invalid Text
t
  convert Validated a
NotInvalid = Validated b
forall {k} (a :: k). Validated a
NotInvalid
  convert Validated a
Valid = Validated b
forall {k} (a :: k). Validated a
Valid


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


{-
@
'field' \@User id Style.invalid $ do
  'label' \"Username\"
  'input' Username ('placeholder' "username")
  el_ 'invalidText'
@
-}
invalidText :: forall a id. View (Input id Validated a) ()
invalidText :: forall a id. View (Input id Validated a) ()
invalidText = do
  Input FieldName a
_ Validated a
v <- View (Input id Validated a) (Input id Validated a)
forall context. View context context
context
  case Validated a
v of
    Invalid Text
t -> Text -> View (Input id Validated a) ()
forall c. Text -> View c ()
text Text
t
    Validated a
_ -> View (Input id Validated a) ()
forall c. View c ()
none


-- | specify a check for a 'Validation'
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)]


-- validateWith :: forall a fs v. (FormField a, Elem a fs, ValidationState v) => v a -> Validation' v fs
-- validateWith v = Validation [(inputName @a, convert v)]

-- eh... not sure how to do this...
anyInvalid :: forall form val. (Form form val, ValidationState val) => form val -> Bool
anyInvalid :: forall (form :: (* -> *) -> *) (val :: * -> *).
(Form form val, ValidationState val) =>
form val -> Bool
anyInvalid form val
f = (val () -> Bool) -> [val ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any val () -> Bool
forall a. val a -> Bool
forall (v :: * -> *) a. ValidationState v => v a -> Bool
isInvalid (form val -> [val ()]
forall (form :: (* -> *) -> *) (val :: * -> *).
(Form form val, ValidationState val) =>
form val -> [val ()]
collectValids form val
f :: [val ()])


-- any (isInvalid . snd) vs

fieldValid :: View (Input id v a) (v a)
fieldValid :: forall id (v :: * -> *) a. View (Input id v a) (v a)
fieldValid = do
  Input FieldName a
_ v a
v <- View (Input id v a) (Input id v a)
forall context. View context context
context
  v a -> View (Input id v a) (v a)
forall a. a -> View (Input id v a) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v a
v


data FieldName a = FieldName Text
  deriving (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)


data Invalid a


data Input (id :: Type) (valid :: Type -> Type) (a :: Type) = Input
  { forall id (valid :: * -> *) a. Input id valid a -> FieldName a
inputName :: FieldName a
  , forall id (valid :: * -> *) a. Input id valid a -> valid a
valid :: valid a
  }


{- | Display a 'FormField'

@
data Age = Age Int deriving (Generic, FormField)

myForm = do
  'form' SignUp mempty id $ do
    field @Age id id $ do
     'label' "Age"
     'input' Number (placeholder "42")
@
-}
field
  :: forall (id :: Type) (v :: Type -> Type) (a :: Type)
   . FormField v a
  -> (v a -> Mod (FormFields id))
  -> View (Input id v a) ()
  -> View (FormFields id) ()
field :: forall id (v :: * -> *) a.
FormField v a
-> (v a -> Mod (FormFields id))
-> View (Input id v a) ()
-> View (FormFields id) ()
field FormField v a
fld v a -> Mod (FormFields id)
md View (Input id v a) ()
cnt = do
  Text
-> Mod (FormFields id)
-> View (FormFields id) ()
-> View (FormFields id) ()
forall c. Text -> Mod c -> View c () -> View c ()
tag Text
"label" (v a -> Mod (FormFields id)
md FormField v a
fld.validated Mod (FormFields id) -> Mod (FormFields id) -> Mod (FormFields id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod (FormFields id)
forall c. Mod c
flexCol) (View (FormFields id) () -> View (FormFields id) ())
-> View (FormFields id) () -> View (FormFields id) ()
forall a b. (a -> b) -> a -> b
$ do
    Input id v a -> View (Input id v a) () -> View (FormFields id) ()
forall context c. context -> View context () -> View c ()
addContext (FieldName a -> v a -> Input id v a
forall id (valid :: * -> *) a.
FieldName a -> valid a -> Input id valid a
Input FormField v a
fld.fieldName FormField v a
fld.validated) View (Input id v a) ()
cnt


-- | label for a 'field'
label :: Text -> View (Input id v a) ()
label :: forall id (v :: * -> *) a. Text -> View (Input id v a) ()
label = Text -> View (Input id v a) ()
forall c. Text -> View c ()
text


-- | input for a 'field'
input :: InputType -> Mod (Input id v a) -> View (Input id v a) ()
input :: forall id (v :: * -> *) a.
InputType -> Mod (Input id v a) -> View (Input id v a) ()
input InputType
ft Mod (Input id v a)
f = do
  Input (FieldName Text
nm) v a
_ <- View (Input id v a) (Input id v a)
forall context. View context context
context
  Text
-> Mod (Input id v a)
-> View (Input id v a) ()
-> View (Input id v a) ()
forall c. Text -> Mod c -> View c () -> View c ()
tag Text
"input" (Mod (Input id v a)
f Mod (Input id v a) -> Mod (Input id v a) -> Mod (Input id v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Mod (Input id v a)
forall c. Text -> Mod c
name Text
nm Mod (Input id v a) -> Mod (Input id v a) -> Mod (Input id v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Mod (Input id v a)
forall c. Text -> Text -> Mod c
att Text
"type" (InputType -> Text
forall {a}. IsString a => InputType -> a
inpType InputType
ft) Mod (Input id v a) -> Mod (Input id v a) -> Mod (Input id v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Mod (Input id v a)
forall c. Text -> Text -> Mod c
att Text
"autocomplete" (InputType -> Text
auto InputType
ft)) View (Input id v 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 id
placeholder :: forall c. Text -> Mod c
placeholder = Text -> Text -> Mod id
forall c. Text -> Text -> Mod c
att Text
"placeholder"


-- | textarea for a 'field'
textarea :: Mod (Input id v a) -> Maybe Text -> View (Input id v a) ()
textarea :: forall id (v :: * -> *) a.
Mod (Input id v a) -> Maybe Text -> View (Input id v a) ()
textarea Mod (Input id v a)
f Maybe Text
mDefaultText = do
  Input (FieldName Text
nm) v a
_ <- View (Input id v a) (Input id v a)
forall context. View context context
context
  Text
-> Mod (Input id v a)
-> View (Input id v a) ()
-> View (Input id v a) ()
forall c. Text -> Mod c -> View c () -> View c ()
tag Text
"textarea" (Mod (Input id v a)
f Mod (Input id v a) -> Mod (Input id v a) -> Mod (Input id v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Mod (Input id v a)
forall c. Text -> Mod c
name Text
nm) (Text -> View (Input id v a) ()
forall c. Text -> View c ()
text (Text -> View (Input id v a) ()) -> Text -> View (Input id v a) ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mDefaultText)


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

@
userForm :: 'Validation' -> 'View' FormView ()
userForm v = do
  form Signup v id $ do
    el Style.h1 "Sign Up"

    'field' \@User id Style.invalid $ do
      'label' \"Username\"
      'input' Username ('placeholder' "username")
      el_ 'invalidText'

    'field' \@Age id Style.invalid $ do
      'label' \"Age\"
      'input' Number ('placeholder' "age")
      el_ 'invalidText'

    'submit' (border 1) \"Submit\"
@
-}
form :: (Form form v, ViewAction (Action id)) => Action id -> Mod id -> View (FormFields id) () -> View id ()
form :: forall (form :: (* -> *) -> *) (v :: * -> *) id.
(Form form v, ViewAction (Action id)) =>
Action id -> Mod id -> View (FormFields id) () -> View id ()
form Action id
a Mod id
md View (FormFields id) ()
cnt = do
  id
vid <- View id id
forall context. View context context
context
  Text -> Mod id -> View id () -> View id ()
forall c. Text -> Mod c -> View c () -> View c ()
tag Text
"form" (Action id -> Mod id
forall id. ViewAction (Action id) => Action id -> Mod id
onSubmit Action id
a Mod id -> Mod id -> Mod id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod id
md Mod id -> Mod id -> Mod id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod id
forall c. Mod c
flexCol Mod id -> Mod id -> Mod id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod id
forall c. Mod c
marginEnd0) (View id () -> View id ()) -> View id () -> View id ()
forall a b. (a -> b) -> a -> b
$ do
    FormFields id -> View (FormFields id) () -> View id ()
forall context c. context -> View context () -> View c ()
addContext (id -> FormFields id
forall id. id -> FormFields id
FormFields id
vid) View (FormFields id) ()
cnt
 where
  -- not sure why chrome is adding margin-block-end: 16 to forms? Add to web-view?
  marginEnd0 :: Mod c
marginEnd0 =
    Class -> Mod c
forall c. Class -> Mod c
addClass (Class -> Mod c) -> Class -> Mod c
forall a b. (a -> b) -> a -> b
$
      ClassName -> Class
cls ClassName
"mg-end-0"
        Class -> (Class -> Class) -> Class
forall a b. a -> (a -> b) -> b
& forall val. ToStyleValue val => Text -> val -> Class -> Class
prop @PxRem Text
"margin-block-end" PxRem
0


-- | Button that submits the 'form'. Use 'button' to specify actions other than submit
submit :: Mod (FormFields id) -> View (FormFields id) () -> View (FormFields id) ()
submit :: forall id.
Mod (FormFields id)
-> View (FormFields id) () -> View (FormFields id) ()
submit Mod (FormFields id)
f = Text
-> Mod (FormFields id)
-> View (FormFields id) ()
-> View (FormFields id) ()
forall c. Text -> Mod c -> View c () -> View c ()
tag Text
"button" (Text -> Text -> Mod (FormFields id)
forall c. Text -> Text -> Mod c
att Text
"type" Text
"submit" Mod (FormFields id) -> Mod (FormFields id) -> Mod (FormFields id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod (FormFields id)
f)


type family Field (context :: Type -> Type) a
type instance Field Identity a = a
type instance Field FieldName a = FieldName a
type instance Field (FormField v) a = FormField v a
type instance Field Validated a = Validated a
type instance Field Maybe a = Maybe a
type instance Field (Either String) a = Either String a


formData :: forall form val es. (Form form val, Hyperbole :> es) => Eff es (form Identity)
formData :: forall (form :: (* -> *) -> *) (val :: * -> *) (es :: [Effect]).
(Form form val, Hyperbole :> es) =>
Eff es (form Identity)
formData = do
  Form
f <- Eff es Form
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Form
formBody
  String -> Eff es ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> Eff es ()) -> String -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Form -> String
forall a. Show a => a -> String
show Form
f
  let ef :: Either Text (form Identity)
ef = forall (form :: (* -> *) -> *) (val :: * -> *).
Form form val =>
Form -> Either Text (form Identity)
formParse @form @val Form
f :: Either Text (form Identity)
  case Either Text (form Identity)
ef of
    Left Text
e -> Text -> Eff es (form Identity)
forall (es :: [Effect]) a. (Hyperbole :> es) => Text -> Eff es a
parseError Text
e
    Right form Identity
a -> form Identity -> Eff es (form Identity)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure form Identity
a


{- | Parse a 'FormField' from the request

@
formAction :: ('Hyperbole' :> es, 'UserDB' :> es) => FormView -> FormAction -> 'Eff' es ('View' FormView ())
formAction _ SignUp = do
  a <- formField \@Age
  u <- formField \@User
  saveUserToDB u a
  pure $ el_ "Saved!"
@
-}

-- formField :: forall a es. (FormField a, Hyperbole :> es) => Eff es a
-- formField = do
--   f <- formData
--   case fieldParse f of
--     Left e -> parseError e
--     Right a -> pure a

-- WARNING: needs the capability to
-- TODO: Generate an empty set of field names?
-- TODO: Merge Validation and FieldNames
class Form form (val :: Type -> Type) | form -> val where
  formParse :: FE.Form -> Either Text (form Identity)
  default formParse :: (Generic (form Identity), GFormParse (Rep (form Identity))) => FE.Form -> Either Text (form Identity)
  formParse Form
f = Rep (form Identity) Any -> form Identity
forall a x. Generic a => Rep a x -> a
forall x. Rep (form Identity) x -> form Identity
to (Rep (form Identity) Any -> form Identity)
-> Either Text (Rep (form Identity) Any)
-> Either Text (form Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form -> Either Text (Rep (form Identity) Any)
forall p. Form -> Either Text (Rep (form Identity) p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either Text (f p)
gFormParse Form
f


  collectValids :: (ValidationState val) => form val -> [val ()]
  default collectValids :: (Generic (form val), GCollect (Rep (form val)) val) => form val -> [val ()]
  collectValids form val
f = Rep (form val) Any -> [val ()]
forall p. Rep (form val) p -> [val ()]
forall {k} (ra :: k -> *) (v :: * -> *) (p :: k).
GCollect ra v =>
ra p -> [v ()]
gCollect (form val -> Rep (form val) Any
forall x. form val -> Rep (form val) x
forall a x. Generic a => a -> Rep a x
from form val
f)


  genForm :: form val
  default genForm :: (Generic (form val), GenFields (Rep (form val))) => form val
  genForm = Rep (form val) Any -> form val
forall a x. Generic a => Rep a x -> a
forall x. Rep (form val) x -> form val
to Rep (form val) Any
forall p. Rep (form val) p
forall {k} (f :: k -> *) (p :: k). GenFields f => f p
gGenFields


  genFieldsWith :: form val -> form (FormField val)
  default genFieldsWith
    :: (Generic (form val), Generic (form (FormField val)), GConvert (Rep (form val)) (Rep (form (FormField val))))
    => form val
    -> form (FormField val)
  genFieldsWith form val
fv = Rep (form (FormField val)) Any -> form (FormField val)
forall a x. Generic a => Rep a x -> a
forall x. Rep (form (FormField val)) x -> form (FormField val)
to (Rep (form (FormField val)) Any -> form (FormField val))
-> Rep (form (FormField val)) Any -> form (FormField val)
forall a b. (a -> b) -> a -> b
$ Rep (form val) Any -> Rep (form (FormField val)) Any
forall p. Rep (form val) p -> Rep (form (FormField val)) p
forall {k} (ra :: k -> *) (rc :: k -> *) (p :: k).
GConvert ra rc =>
ra p -> rc p
gConvert (form val -> Rep (form val) Any
forall x. form val -> Rep (form val) x
forall a x. Generic a => a -> Rep a x
from form val
fv)


{- | Generate FormFields for the given instance of 'Form', with no validation information

> let f = formFields @UserForm
> form @UserForm Submit id $ do
>   field f.user id $ do
>     label "Username"
>     input Username (placeholder "Username")
-}
formFields :: (Form form val) => form (FormField val)
formFields :: forall (form :: (* -> *) -> *) (val :: * -> *).
Form form val =>
form (FormField val)
formFields = form val -> form (FormField val)
forall (form :: (* -> *) -> *) (val :: * -> *).
Form form val =>
form val -> form (FormField val)
genFieldsWith form val
forall (form :: (* -> *) -> *) (val :: * -> *).
Form form val =>
form val
genForm


{- | Generate FormFields for the givne instance of 'Form' from validation data

> let valids = UserForm { user = Valid, age = Invalid "must be 20 years old" }
> let f = formFieldsWith @UserForm valids
> form @UserForm Submit id $ do
>   field f.user id $ do
>     label "Username"
>     input Username (placeholder "Username")
-}
formFieldsWith :: (Form form val) => form val -> form (FormField val)
formFieldsWith :: forall (form :: (* -> *) -> *) (val :: * -> *).
Form form val =>
form val -> form (FormField val)
formFieldsWith = form val -> form (FormField val)
forall (form :: (* -> *) -> *) (val :: * -> *).
Form form val =>
form val -> form (FormField val)
genFieldsWith


-- | Automatically derive labels from form field names
class GFormParse f where
  gFormParse :: FE.Form -> Either Text (f p)


-- instance GForm U1 where
--   gForm = U1

instance (GFormParse f, GFormParse g) => GFormParse (f :*: g) where
  gFormParse :: forall (p :: k). Form -> Either Text ((:*:) f g p)
gFormParse Form
f = do
    f p
a <- Form -> Either Text (f p)
forall (p :: k). Form -> Either Text (f p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either Text (f p)
gFormParse Form
f
    g p
b <- Form -> Either Text (g p)
forall (p :: k). Form -> Either Text (g p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either Text (f p)
gFormParse Form
f
    (:*:) f g p -> Either Text ((:*:) f g p)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((:*:) f g p -> Either Text ((:*:) f g p))
-> (:*:) f g p -> Either Text ((:*:) 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 Text (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 Text (f p) -> Either Text (M1 D d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form -> Either Text (f p)
forall (p :: k). Form -> Either Text (f p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either Text (f p)
gFormParse Form
f


instance (GFormParse f) => GFormParse (M1 C c f) where
  gFormParse :: forall (p :: k). Form -> Either Text (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 Text (f p) -> Either Text (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form -> Either Text (f p)
forall (p :: k). Form -> Either Text (f p)
forall {k} (f :: k -> *) (p :: k).
GFormParse f =>
Form -> Either Text (f p)
gFormParse Form
f


instance (Selector s, FromQueryData a) => GFormParse (M1 S s (K1 R a)) where
  gFormParse :: forall (p :: k). Form -> Either Text (M1 S s (K1 R a) p)
gFormParse Form
f = do
    let s :: String
s = 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)
    Text
t <- Text -> Form -> Either Text Text
forall v. FromHttpApiData v => Text -> Form -> Either Text v
parseUnique (String -> Text
pack String
s) Form
f
    String -> Either Text ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (Text -> String
forall a. Show a => a -> String
show Text
t)
    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)
-> Either Text a -> Either Text (M1 S s (K1 R a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text a
forall a. FromQueryData a => Text -> Either Text a
parseQueryData Text
t


------------------------------------------------------------------------------
-- GEN FIELDS :: Create the field! -------------------------------------------
------------------------------------------------------------------------------

class GenFields f where
  gGenFields :: f p


instance GenFields U1 where
  gGenFields :: forall (p :: k). U1 p
gGenFields = U1 p
forall k (p :: k). U1 p
U1


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


instance (Selector s, GenField f a, Field f a ~ f a) => GenFields (M1 S s (K1 R (f a))) where
  gGenFields :: forall (p :: k). M1 S s (K1 R (f a)) p
gGenFields =
    let sel :: String
sel = M1 S s (K1 R (f 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} {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 (f a) p -> M1 S s (K1 R (f a)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (f a) p -> M1 S s (K1 R (f a)) p)
-> (Field f a -> K1 R (f a) p)
-> Field f a
-> M1 S s (K1 R (f a)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> K1 R (f a) p
Field f a -> K1 R (f a) p
forall k i c (p :: k). c -> K1 i c p
K1 (Field f a -> M1 S s (K1 R (f a)) p)
-> Field f a -> M1 S s (K1 R (f a)) p
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. GenField f a => String -> Field f a
genField @f @a String
sel


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


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


------------------------------------------------------------------------------
-- GenField -- Generate a value from the selector name
------------------------------------------------------------------------------

class GenField f a where
  genField :: String -> Field f a


instance GenField FieldName a where
  genField :: String -> Field 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 -> Field 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 (FormField Validated) a where
  genField :: String -> Field (FormField Validated) a
genField String
s = FieldName a -> Validated a -> FormField Validated a
forall {k} (v :: k -> *) (a :: k).
FieldName a -> v a -> FormField v a
FormField (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) Validated a
forall {k} (a :: k). Validated a
NotInvalid


instance GenField (FormField Maybe) a where
  genField :: String -> Field (FormField Maybe) a
genField String
s = FieldName a -> Maybe a -> FormField Maybe a
forall {k} (v :: k -> *) (a :: k).
FieldName a -> v a -> FormField v a
FormField (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) Maybe a
forall a. Maybe a
Nothing


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


------------------------------------------------------------------------------
-- GMerge - 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 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 :: forall (p :: k).
(:*:) ra0 ra1 p -> (:*:) rb0 rb1 p -> (:*:) rc0 rc1 p
gMerge (ra0 p
a0 :*: ra1 p
a1) (rb0 p
b0 :*: rb1 p
b1) = ra0 p -> rb0 p -> rc0 p
forall (p :: k). ra0 p -> rb0 p -> rc0 p
forall {k} (ra :: k -> *) (rb :: k -> *) (rc :: k -> *) (p :: k).
GMerge ra rb rc =>
ra p -> rb p -> rc p
gMerge ra0 p
a0 rb0 p
b0 rc0 p -> rc1 p -> (:*:) rc0 rc1 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: ra1 p -> rb1 p -> rc1 p
forall (p :: k). ra1 p -> rb1 p -> rc1 p
forall {k} (ra :: k -> *) (rb :: k -> *) (rc :: k -> *) (p :: k).
GMerge ra rb rc =>
ra p -> rb p -> rc p
gMerge ra1 p
a1 rb1 p
b1


instance (GMerge ra rb rc) => GMerge (M1 D d ra) (M1 D d rb) (M1 D d rc) where
  gMerge :: forall (p :: k). M1 D d ra p -> M1 D d rb p -> M1 D d rc p
gMerge (M1 ra p
fa) (M1 rb p
fb) = rc p -> M1 D d rc p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rc p -> M1 D d rc p) -> rc p -> M1 D d rc p
forall a b. (a -> b) -> a -> b
$ ra p -> rb p -> rc p
forall (p :: k). ra p -> rb p -> rc p
forall {k} (ra :: k -> *) (rb :: k -> *) (rc :: k -> *) (p :: k).
GMerge ra rb rc =>
ra p -> rb p -> rc p
gMerge ra p
fa rb p
fb


instance (GMerge ra rb rc) => GMerge (M1 C d ra) (M1 C d rb) (M1 C d rc) where
  gMerge :: forall (p :: k). M1 C d ra p -> M1 C d rb p -> M1 C d rc p
gMerge (M1 ra p
fa) (M1 rb p
fb) = rc p -> M1 C d rc p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rc p -> M1 C d rc p) -> rc p -> M1 C d rc p
forall a b. (a -> b) -> a -> b
$ ra p -> rb p -> rc p
forall (p :: k). ra p -> rb p -> rc p
forall {k} (ra :: k -> *) (rb :: k -> *) (rc :: k -> *) (p :: k).
GMerge ra rb rc =>
ra p -> rb p -> rc p
gMerge ra p
fa rb p
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 :: forall (p :: k).
M1 S s (K1 R a) p -> M1 S s (K1 R b) p -> M1 S s (K1 R c) p
gMerge (M1 (K1 a
a)) (M1 (K1 b
b)) = K1 R c p -> M1 S s (K1 R c) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R c p -> M1 S s (K1 R c) p)
-> (c -> K1 R c p) -> c -> M1 S s (K1 R c) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> K1 R c p
forall k i c (p :: k). c -> K1 i c p
K1 (c -> M1 S s (K1 R c) p) -> c -> M1 S s (K1 R c) p
forall a b. (a -> b) -> a -> b
$ a -> b -> c
forall a b c. MergeField a b c => a -> b -> c
mergeField a
a b
b


class MergeField a b c where
  mergeField :: a -> b -> c


instance MergeField (FieldName a) (Validated a) (FormField Validated a) where
  mergeField :: FieldName a -> Validated a -> FormField Validated a
mergeField = FieldName a -> Validated a -> FormField Validated a
forall {k} (v :: k -> *) (a :: k).
FieldName a -> v a -> FormField v a
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 :: forall (p :: k). (:*:) ra0 ra1 p -> (:*:) rc0 rc1 p
gConvert (ra0 p
a0 :*: ra1 p
a1) = ra0 p -> rc0 p
forall (p :: k). ra0 p -> rc0 p
forall {k} (ra :: k -> *) (rc :: k -> *) (p :: k).
GConvert ra rc =>
ra p -> rc p
gConvert ra0 p
a0 rc0 p -> rc1 p -> (:*:) rc0 rc1 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: ra1 p -> rc1 p
forall (p :: k). ra1 p -> rc1 p
forall {k} (ra :: k -> *) (rc :: k -> *) (p :: k).
GConvert ra rc =>
ra p -> rc p
gConvert ra1 p
a1


instance (GConvert ra rc) => GConvert (M1 D d ra) (M1 D d rc) where
  gConvert :: forall (p :: k). M1 D d ra p -> M1 D d rc p
gConvert (M1 ra p
fa) = rc p -> M1 D d rc p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rc p -> M1 D d rc p) -> rc p -> M1 D d rc p
forall a b. (a -> b) -> a -> b
$ ra p -> rc p
forall (p :: k). ra p -> rc p
forall {k} (ra :: k -> *) (rc :: k -> *) (p :: k).
GConvert ra rc =>
ra p -> rc p
gConvert ra p
fa


instance (GConvert ra rc) => GConvert (M1 C d ra) (M1 C d rc) where
  gConvert :: forall (p :: k). M1 C d ra p -> M1 C d rc p
gConvert (M1 ra p
fa) = rc p -> M1 C d rc p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rc p -> M1 C d rc p) -> rc p -> M1 C d rc p
forall a b. (a -> b) -> a -> b
$ ra p -> rc p
forall (p :: k). ra p -> rc p
forall {k} (ra :: k -> *) (rc :: k -> *) (p :: k).
GConvert ra rc =>
ra p -> rc p
gConvert ra p
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 :: forall (p :: k). M1 S s (K1 R (f a)) p -> M1 S s (K1 R (g a)) p
gConvert (M1 (K1 f a
inp)) =
    let sel :: String
sel = M1 S s (K1 R (f 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} {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 (g a) p -> M1 S s (K1 R (g a)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (g a) p -> M1 S s (K1 R (g a)) p)
-> (g a -> K1 R (g a) p) -> g a -> M1 S s (K1 R (g a)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> K1 R (g a) p
forall k i c (p :: k). c -> K1 i c p
K1 (g a -> M1 S s (K1 R (g a)) p) -> g a -> M1 S s (K1 R (g a)) p
forall a b. (a -> b) -> a -> b
$ forall (inp :: * -> *) (f :: * -> *) a.
GenFieldFrom inp f a =>
String -> inp a -> Field f a
genFieldFrom @f @g String
sel f a
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 :: String -> val a -> Field (FormField val) a
genFieldFrom String
s = FieldName a -> val a -> FormField val a
forall {k} (v :: k -> *) (a :: k).
FieldName a -> v a -> FormField v a
FormField (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)


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

class GCollect ra v where
  gCollect :: ra p -> [v ()]


instance GCollect U1 v where
  gCollect :: forall (p :: k). U1 p -> [v ()]
gCollect U1 p
_ = []


instance (GCollect f v, GCollect g v) => GCollect (f :*: g) v where
  gCollect :: forall (p :: k). (:*:) f g p -> [v ()]
gCollect (f p
a :*: g p
b) = f p -> [v ()]
forall (p :: k). f p -> [v ()]
forall {k} (ra :: k -> *) (v :: * -> *) (p :: k).
GCollect ra v =>
ra p -> [v ()]
gCollect f p
a [v ()] -> [v ()] -> [v ()]
forall a. Semigroup a => a -> a -> a
<> g p -> [v ()]
forall (p :: k). g p -> [v ()]
forall {k} (ra :: k -> *) (v :: * -> *) (p :: k).
GCollect ra v =>
ra p -> [v ()]
gCollect g p
b


instance (Selector s, ValidationState v) => GCollect (M1 S s (K1 R (v a))) v where
  gCollect :: forall (p :: k). M1 S s (K1 R (v a)) p -> [v ()]
gCollect (M1 (K1 v a
val)) = [v a -> v ()
forall a b. v a -> v b
forall (v :: * -> *) a b. ValidationState v => v a -> v b
convert v a
val]


instance (GCollect f v) => GCollect (M1 D d f) v where
  gCollect :: forall (p :: k). M1 D d f p -> [v ()]
gCollect (M1 f p
f) = f p -> [v ()]
forall (p :: k). f p -> [v ()]
forall {k} (ra :: k -> *) (v :: * -> *) (p :: k).
GCollect ra v =>
ra p -> [v ()]
gCollect f p
f


instance (GCollect f v) => GCollect (M1 C c f) v where
  gCollect :: forall (p :: k). M1 C c f p -> [v ()]
gCollect (M1 f p
f) = f p -> [v ()]
forall (p :: k). f p -> [v ()]
forall {k} (ra :: k -> *) (v :: * -> *) (p :: k).
GCollect ra v =>
ra p -> [v ()]
gCollect f p
f

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