{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE IncoherentInstances   #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{-|
Module: IHP.View.Form.FormFor
Description: 'formFor' and form building utilities
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.View.Form.FormFor where

import           IHP.Controller.Context
import           IHP.HSX.ConvertibleStrings ()
import           IHP.HSX.MarkupQQ (hsx)
import           IHP.ModelSupport (Id', InputValue, getModelName, isNew)
import           IHP.Prelude
import           IHP.View.Form.Fields (hiddenField)
import           IHP.View.Types
import           IHP.ViewSupport
import           Network.Wai (Request, pathInfo)
import IHP.HSX.Markup (Markup, ToHtml(..))

-- | Forms usually begin with a 'formFor' expression.
--
-- This is how a simple form can look like:
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor post [hsx|
-- >     {textField #title}
-- >     {textareaField #body}
-- >     {submitButton}
-- > |]
--
-- Calling this form from inside your HSX code will lead to the following HTML being generated:
--
-- > <form method="POST" action="/CreatePost" id="" class="new-form">
-- >     <div class="form-group" id="form-group-post_title">
-- >         <label for="post_title">Title</label>
-- >         <input type="text" name="title" id="post_title" class="form-control" />
-- >     </div>
-- >
-- >     <div class="form-group" id="form-group-post_body">
-- >         <label for="post_body">Body</label>
-- >         <textarea name="body" id="post_body" class="form-control"></textarea>
-- >     </div>
-- >
-- >     <button class="btn btn-primary">Create Post</button>
-- > </form>
--
-- You can see that the form is submitted via @POST@. The form action has also been set by default to @/CreatePost@.
--
-- All inputs have auto-generated class names and ids for styling. Also, all @name@ attributes are set as expected.
--
-- __Field Values:__
--
-- A form control is always filled with the value of the given field when rendering. For example, given a post
--
-- > let post = Post { ..., title = "Hello World" }
--
-- Rendering this, the input value will be set like:
--
-- >>> {textField #title}
-- <input ... value="Hello World" />
--
-- __Validation:__
--
-- When rendering a record that has failed validation, the validation error message will be rendered automatically.
--
-- Given a post like this:
--
-- > let post = Post { ..., title = "" }
-- >     |> validateField #title nonEmpty
--
-- Rendering @{textField #title}@, the input will have the css class @is-invalid@ and an element with the error message will be rendered below the input:
--
-- > <div class="form-group" id="form-group-post_title">
-- >     <label for="post_title">Title</label>
-- >     <input
-- >         type="text"
-- >         name="title"
-- >         placeholder=""
-- >         id="post_title"
-- >         class="form-control is-invalid "
-- >     />
-- >     <div class="invalid-feedback">This field cannot be empty</div>
-- > </div>
formFor :: forall record. (
    ?context :: ControllerContext
    , ?request :: Request
    , ModelFormAction record
    , HasField "meta" record MetaBag
    ) => record -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup
formFor :: forall record.
(?context::ControllerContext, ?request::Request,
 ModelFormAction record, HasField "meta" record MetaBag) =>
record
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
formFor record
record (?context::ControllerContext, ?formContext::FormContext record) =>
Markup
formBody = forall record.
(?context::ControllerContext, ?request::Request,
 ModelFormAction record, HasField "meta" record MetaBag) =>
record
-> (FormContext record -> FormContext record)
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
formForWithOptions @record record
record (\FormContext record
c -> FormContext record
c) Markup
(?context::ControllerContext, ?formContext::FormContext record) =>
Markup
formBody
{-# INLINE formFor #-}

-- | Like 'formFor' but allows changing the underlying 'FormContext'
--
-- This is how you can render a form with a @id="post-form"@ id attribute and a custom @data-post-id@ attribute:
--
-- > renderForm :: Post -> Html
-- > renderForm post = formForWithOptions formOptions post [hsx|
-- >     {textField #title}
-- >     {textareaField #body}
-- >     {submitButton}
-- > |]
-- >
-- > formOptions :: FormContext Post -> FormContext Post
-- > formOptions formContext = formContext
-- >     |> set #formId "post-form"
-- >     |> set #customFormAttributes [("data-post-id", show formContext.model.id)]
--
formForWithOptions :: forall record. (
    ?context :: ControllerContext
    , ?request :: Request
    , ModelFormAction record
    , HasField "meta" record MetaBag
    ) => record -> (FormContext record -> FormContext record) -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup
formForWithOptions :: forall record.
(?context::ControllerContext, ?request::Request,
 ModelFormAction record, HasField "meta" record MetaBag) =>
record
-> (FormContext record -> FormContext record)
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
formForWithOptions record
record FormContext record -> FormContext record
applyOptions (?context::ControllerContext, ?formContext::FormContext record) =>
Markup
formBody = FormContext record
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
forall model.
(?context::ControllerContext) =>
FormContext model
-> ((?context::ControllerContext,
     ?formContext::FormContext model) =>
    Markup)
-> Markup
buildForm (FormContext record -> FormContext record
applyOptions (record -> FormContext record
forall record.
(?request::Request, HasField "meta" record MetaBag) =>
record -> FormContext record
createFormContext record
record) { formAction = modelFormAction record }) Markup
(?context::ControllerContext, ?formContext::FormContext record) =>
Markup
formBody
{-# INLINE formForWithOptions #-}

-- | Like 'formFor' but disables the IHP javascript helpers.
--
-- Use it like this:
--
-- > renderForm :: Post -> Html
-- > renderForm post = formForWithoutJavascript post [hsx|
-- >     {textField #title}
-- >     {textareaField #body}
-- >     {submitButton}
-- > |]
--
-- If you want to use this with e.g. a custom form action, remember that 'formForWithoutJavascript' is just a shortcut for 'formForWithOptions':
--
-- > renderForm :: Post -> Html
-- > renderForm post = formForWithOptions formOptions post [hsx|
-- >     {textField #title}
-- >     {textareaField #body}
-- >     {submitButton}
-- > |]
-- >
-- > formOptions :: FormContext Post -> FormContext Post
-- > formOptions formContext = formContext
-- >     |> set #formAction (pathTo BespokeNewPostAction)
-- >     |> set #disableJavascriptSubmission True
--
formForWithoutJavascript :: forall record. (
    ?context :: ControllerContext
    , ?request :: Request
    , ModelFormAction record
    , HasField "meta" record MetaBag
    ) => record -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup
formForWithoutJavascript :: forall record.
(?context::ControllerContext, ?request::Request,
 ModelFormAction record, HasField "meta" record MetaBag) =>
record
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
formForWithoutJavascript record
record (?context::ControllerContext, ?formContext::FormContext record) =>
Markup
formBody = forall record.
(?context::ControllerContext, ?request::Request,
 ModelFormAction record, HasField "meta" record MetaBag) =>
record
-> (FormContext record -> FormContext record)
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
formForWithOptions @record record
record (\FormContext record
formContext -> FormContext record
formContext { disableJavascriptSubmission = True }) Markup
(?context::ControllerContext, ?formContext::FormContext record) =>
Markup
formBody
{-# INLINE formForWithoutJavascript #-}

-- | Allows a custom form action (form submission url) to be set
--
-- The URL where the form is going to be submitted to is specified in HTML using the form's @action@ attribute. When using 'formFor' the @action@ attribute is automatically set to the expected path.
--
-- E.g. given the below 'formFor' code, the @action@ is set to @/CreatePost@ or @/UpdatePost@:
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor post [hsx|
-- >     {textField #title}
-- >     {textareaField #body}
-- >     {submitButton}
-- > |]
--
-- To override the auto-generated @action@ attribute use the 'formFor\'' function:
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor' post "/my-custom-endpoint" [hsx||]
--
-- If you pass an action to that, you need to wrap it with 'pathTo':
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor' post (pathTo CreateDraftAction) [hsx||]
--
formFor' :: forall record. (
    ?context :: ControllerContext
    , ?request :: Request
    , HasField "meta" record MetaBag
    ) => record -> Text -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup
formFor' :: forall record.
(?context::ControllerContext, ?request::Request,
 HasField "meta" record MetaBag) =>
record
-> Text
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
formFor' record
record Text
action = FormContext record
-> ((?context::ControllerContext,
     ?formContext::FormContext record) =>
    Markup)
-> Markup
forall model.
(?context::ControllerContext) =>
FormContext model
-> ((?context::ControllerContext,
     ?formContext::FormContext model) =>
    Markup)
-> Markup
buildForm (record -> FormContext record
forall record.
(?request::Request, HasField "meta" record MetaBag) =>
record -> FormContext record
createFormContext record
record) { formAction = action }
{-# INLINE formFor' #-}

-- | Used by 'formFor' to make a new form context
createFormContext :: forall record. (
        ?request :: Request
        , HasField "meta" record MetaBag
        ) => record -> FormContext record
createFormContext :: forall record.
(?request::Request, HasField "meta" record MetaBag) =>
record -> FormContext record
createFormContext record
record =
    FormContext
        { model :: record
model = record
record
        , formAction :: Text
formAction = Text
""
        , formMethod :: Text
formMethod = Text
"POST"
        , cssFramework :: CSSFramework
cssFramework = CSSFramework
(?request::Request) => CSSFramework
theCSSFramework
        , formId :: Text
formId = Text
""
        , formClass :: Text
formClass = if record -> Bool
forall model. HasField "meta" model MetaBag => model -> Bool
isNew record
record then Text
"new-form" else Text
"edit-form"
        , customFormAttributes :: [(Text, Text)]
customFormAttributes = []
        , disableJavascriptSubmission :: Bool
disableJavascriptSubmission = Bool
False
        , fieldNamePrefix :: Text
fieldNamePrefix = Text
""
        }
{-# INLINE createFormContext #-}

-- | Used by 'formFor' to render the form
buildForm :: forall model. (?context :: ControllerContext) => FormContext model -> ((?context :: ControllerContext, ?formContext :: FormContext model) => Markup) -> Markup
buildForm :: forall model.
(?context::ControllerContext) =>
FormContext model
-> ((?context::ControllerContext,
     ?formContext::FormContext model) =>
    Markup)
-> Markup
buildForm FormContext model
formContext (?context::ControllerContext, ?formContext::FormContext model) =>
Markup
inner = [hsx|
        <form
            method={formContext.formMethod}
            action={formContext.formAction}
            id={formContext.formId}
            class={formContext.formClass}
            data-disable-javascript-submission={formContext.disableJavascriptSubmission}
            {...formContext.customFormAttributes}
        >
            {formInner}
        </form>
    |]
        where
            formInner :: Markup
formInner = let ?formContext = ?formContext::FormContext model
FormContext model
formContext in Markup
(?context::ControllerContext, ?formContext::FormContext model) =>
Markup
inner
{-# INLINE buildForm #-}

nestedFormFor :: forall fieldName childRecord parentRecord idType. (
    ?context :: ControllerContext
    , ?formContext :: FormContext parentRecord
    , HasField fieldName parentRecord [childRecord]
    , KnownSymbol fieldName
    , KnownSymbol (GetModelName childRecord)
    , HasField "id" childRecord idType
    , InputValue idType
    , HasField "meta" childRecord MetaBag
    ) => Proxy fieldName -> ((?context :: ControllerContext, ?formContext :: FormContext childRecord) => Markup) -> Markup
nestedFormFor :: forall (fieldName :: Symbol) childRecord parentRecord idType.
(?context::ControllerContext,
 ?formContext::FormContext parentRecord,
 HasField fieldName parentRecord [childRecord],
 KnownSymbol fieldName, KnownSymbol (GetModelName childRecord),
 HasField "id" childRecord idType, InputValue idType,
 HasField "meta" childRecord MetaBag) =>
Proxy fieldName
-> ((?context::ControllerContext,
     ?formContext::FormContext childRecord) =>
    Markup)
-> Markup
nestedFormFor Proxy fieldName
field (?context::ControllerContext,
 ?formContext::FormContext childRecord) =>
Markup
nestedRenderForm = [childRecord] -> (Element [childRecord] -> Markup) -> Markup
forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forEach [childRecord]
children childRecord -> Markup
Element [childRecord] -> Markup
renderChild
    where
        parentFormContext :: FormContext parentRecord
        parentFormContext :: FormContext parentRecord
parentFormContext = ?formContext::FormContext parentRecord
FormContext parentRecord
?formContext

        renderChild :: childRecord -> Markup
        renderChild :: childRecord -> Markup
renderChild childRecord
record = let ?formContext = childRecord -> FormContext childRecord
buildNestedFormContext childRecord
record in [hsx|
            {hiddenField #id}
            {nestedRenderForm}
        |]

        buildNestedFormContext :: childRecord -> FormContext childRecord
        buildNestedFormContext :: childRecord -> FormContext childRecord
buildNestedFormContext childRecord
record = FormContext parentRecord
parentFormContext { model = record, fieldNamePrefix = symbolToText @fieldName <> "_" }

        children :: [childRecord]
        children :: [childRecord]
children = forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @fieldName ?formContext::FormContext parentRecord
FormContext parentRecord
?formContext.model
{-# INLINE nestedFormFor #-}

-- | Renders a submit button
--
-- > <button class="btn btn-primary">Create Post</button>
--
-- __Example:__
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor post [hsx|
-- >     {submitButton}
-- > |]
--
-- This will generate code like this:
--
-- > <form method="POST" action="/CreatePost" id="" class="new-form">
-- >     <button class="btn btn-primary">Create Post</button>
-- > </form>
--
-- __Custom Text__
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor post [hsx|
-- >     {submitButton { label = "Create it!" } }
-- > |]
--
-- This will generate code like this:
--
-- > <form method="POST" action="/CreatePost" id="" class="new-form">
-- >     <button class="btn btn-primary">Create it!</button>
-- > </form>
--
-- __Custom Class__
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor post [hsx|
-- >     {submitButton { buttonClass = "create-button" } }
-- > |]
--
-- This will generate code like this:
--
-- > <form method="POST" action="/CreatePost" id="" class="new-form">
-- >     <button class="btn btn-primary create-button">Create Post</button>
-- > </form>
--
-- __Disabled button__
--
-- > renderForm :: Post -> Html
-- > renderForm post = formFor post [hsx|
-- >     {submitButton { buttonDisabled = True } }
-- > |]
--
-- This will generate code like this:
--
-- > <form method="POST" action="/CreatePost" id="" class="new-form">
-- >     <button class="btn btn-primary create-button" disabled="disabled">Create Post</button>
-- > </form>
submitButton :: forall model. (?formContext :: FormContext model, HasField "meta" model MetaBag, KnownSymbol (GetModelName model)) => SubmitButton
submitButton :: forall model.
(?formContext::FormContext model, HasField "meta" model MetaBag,
 KnownSymbol (GetModelName model)) =>
SubmitButton
submitButton =
    let
        modelName :: Text
modelName = forall model. KnownSymbol (GetModelName model) => Text
IHP.ModelSupport.getModelName @model
        buttonText :: Text
buttonText = Text
modelName Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Text
humanize -- We do this to turn 'Create ProjectTask' into 'Create Project Task'
        isNew :: Bool
isNew = model -> Bool
forall model. HasField "meta" model MetaBag => model -> Bool
IHP.ModelSupport.isNew (FormContext model -> model
forall model. FormContext model -> model
model ?formContext::FormContext model
FormContext model
?formContext)
    in SubmitButton
    { label :: Markup
label = Text -> Markup
forall a. ToHtml a => a -> Markup
toHtml (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ (if Bool
isNew then Text
"Create " else Text
"Save ") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
buttonText
    , buttonClass :: Text
buttonClass = Text
forall a. Monoid a => a
mempty
    , buttonDisabled :: Bool
buttonDisabled = Bool
False
    , cssFramework :: CSSFramework
cssFramework = ?formContext::FormContext model
FormContext model
?formContext.cssFramework
    }
{-# INLINE submitButton #-}

-- | Returns the form's action attribute for a given record.
class ModelFormAction record where
    modelFormAction :: (?context :: ControllerContext, ?request :: Request) => record -> Text

instance
    ( HasField "id" record (Id' (GetTableName record))
    , HasField "meta" record MetaBag
    , KnownSymbol (GetModelName record)
    , Show (Id' (GetTableName record))
    ) => ModelFormAction record where
    -- | Returns the form's action attribute for a given record.
    --
    -- Expects that AutoRoute is used. Otherwise you need to use @formFor'@ or specify
    -- a manual ModelFormAction instance.
    --
    -- We guess the form submit action based on the current url
    -- It's a @New..Action@ or @Edit..Action@. We guess the corresponding
    -- @Create..Action@ name or @Update..Action@ name based on the AutoRoute rules
    --
    -- In case the routing is not based on AutoRoute, a manual ModelFormAction instance needs
    -- to be defined
    modelFormAction :: (?context::ControllerContext, ?request::Request) => record -> Text
modelFormAction record
record =
        let
            path :: [Text]
path = Request
(?request::Request) => Request
theRequest.pathInfo
            action :: Text
action = if record -> Bool
forall model. HasField "meta" model MetaBag => model -> Bool
isNew record
record
                then Text
"Create" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall model. KnownSymbol (GetModelName model) => Text
getModelName @record
                else Text
"Update" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall model. KnownSymbol (GetModelName model) => Text
getModelName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcfirst (forall model. KnownSymbol (GetModelName model) => Text
getModelName @record) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Id=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id' (GetTableName record) -> Text
forall a. Show a => a -> Text
tshow record
record.id
        in
            [Text] -> Maybe [Text]
forall a. [a] -> Maybe [a]
init [Text]
path
                Maybe [Text] -> (Maybe [Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> (\Maybe [Text]
path -> [Text
""] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
path) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
action])
                [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
intercalate Text
"/"