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

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

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

import Control.Applicative ((<|>))
import Data.Aeson (FromJSON, ToJSON)
import Data.Bifunctor (first, second)
import Data.ByteString qualified as BS
import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.String.Conversions (cs)
import Data.Text (Text, pack)
import Data.Time.Clock (UTCTime)
import Effectful
import GHC.Generics
import Network.URI
import Text.Casing (kebab)
import Text.Read (readMaybe)
import Web.Atomic.Types hiding (Selector)
import Web.Hyperbole.Data.Argument
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Request (formBody)
import Web.Hyperbole.Effect.Response (parseError)
import Web.Hyperbole.HyperView.Event (onSubmit)
import Web.Hyperbole.HyperView.Input (Option (..), checked)
import Web.Hyperbole.HyperView.Types
import Web.Hyperbole.Types.Request
import Web.Hyperbole.View


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

type ParamKey = BS.ByteString


{- ! Simple types that be decoded from form data

@
#EMBED Example.FormSimple data ContactForm
@
-}

{- | Simple types that be decoded from form data

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


{- ! A Higher-Kinded type that can be parsed from a 'Form'

@
#EMBED Example.FormValidation data UserForm
@
-}

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

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


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


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


lookupField :: ParamKey -> Form -> Maybe FormParam
lookupField :: ParamKey -> Form -> Maybe FormParam
lookupField ParamKey
key Form
f = Text -> FormParam
FormParam (Text -> FormParam) -> (ParamKey -> Text) -> ParamKey -> FormParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamKey -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ParamKey -> FormParam) -> Maybe ParamKey -> Maybe FormParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamKey -> [(ParamKey, ParamKey)] -> Maybe ParamKey
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ParamKey
key Form
f.params Maybe FormParam -> Maybe FormParam -> Maybe FormParam
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UploadedFile -> FormParam
FileParam (UploadedFile -> FormParam)
-> Maybe UploadedFile -> Maybe FormParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamKey -> [(ParamKey, UploadedFile)] -> Maybe UploadedFile
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ParamKey
key Form
f.files


parseField :: forall a. (FromField a) => ParamKey -> Form -> Either String a
parseField :: forall a. FromField a => ParamKey -> Form -> Either String a
parseField ParamKey
key Form
f = do
  let Maybe FormParam
mt :: Maybe FormParam = ParamKey -> Form -> Maybe FormParam
lookupField ParamKey
key Form
f
  a <- (String -> String) -> Either String a -> Either String a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
err -> ParamKey -> String
forall a b. ConvertibleStrings a b => a -> b
cs ParamKey
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err) (Either String a -> Either String a)
-> Either String a -> Either String a
forall a b. (a -> b) -> a -> b
$ forall a. FromField a => Maybe FormParam -> Either String a
fromField @a Maybe FormParam
mt
  pure a


-- where
--  -- lookupFile = FileField <$> lookup key req.files
--  lookupParam = ParamField . ParamValue . cs <$>

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

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

@
#EMBED Example.FormValidation data UserForm
@

@
#EMBED Example.Contacts newContactForm
@
-}

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

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

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


{- ! Generate FieldNames for a form

> #EMBED Example.Todos.Todo data TodoForm
>
> #EMBED Example.Todos.Todo todoForm
-}

{- | Generate FieldNames for a form

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


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


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


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


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


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

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


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

@
#EMBED Example.FormSimple formView
@
-}

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

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

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

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

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

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

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

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


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


-- | Form FieldName. This is embeded as the name attribute, and refers to the key need to parse the form when submitted. See 'fieldNames'
newtype FieldName a = FieldName {forall {k} (a :: k). FieldName a -> Text
value :: Text}
  deriving newtype (Int -> FieldName a -> String -> String
[FieldName a] -> String -> String
FieldName a -> String
(Int -> FieldName a -> String -> String)
-> (FieldName a -> String)
-> ([FieldName a] -> String -> String)
-> Show (FieldName a)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall k (a :: k). Int -> FieldName a -> String -> String
forall k (a :: k). [FieldName a] -> String -> String
forall k (a :: k). FieldName a -> String
$cshowsPrec :: forall k (a :: k). Int -> FieldName a -> String -> String
showsPrec :: Int -> FieldName a -> String -> String
$cshow :: forall k (a :: k). FieldName a -> String
show :: FieldName a -> String
$cshowList :: forall k (a :: k). [FieldName a] -> String -> String
showList :: [FieldName a] -> String -> String
Show, String -> FieldName a
(String -> FieldName a) -> IsString (FieldName a)
forall a. (String -> a) -> IsString a
forall k (a :: k). String -> FieldName a
$cfromString :: forall k (a :: k). String -> FieldName a
fromString :: String -> FieldName a
IsString, Maybe (FieldName a)
Value -> Parser [FieldName a]
Value -> Parser (FieldName a)
(Value -> Parser (FieldName a))
-> (Value -> Parser [FieldName a])
-> Maybe (FieldName a)
-> FromJSON (FieldName a)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
forall k (a :: k). Maybe (FieldName a)
forall k (a :: k). Value -> Parser [FieldName a]
forall k (a :: k). Value -> Parser (FieldName a)
$cparseJSON :: forall k (a :: k). Value -> Parser (FieldName a)
parseJSON :: Value -> Parser (FieldName a)
$cparseJSONList :: forall k (a :: k). Value -> Parser [FieldName a]
parseJSONList :: Value -> Parser [FieldName a]
$comittedField :: forall k (a :: k). Maybe (FieldName a)
omittedField :: Maybe (FieldName a)
FromJSON, [FieldName a] -> Value
[FieldName a] -> Encoding
FieldName a -> Bool
FieldName a -> Value
FieldName a -> Encoding
(FieldName a -> Value)
-> (FieldName a -> Encoding)
-> ([FieldName a] -> Value)
-> ([FieldName a] -> Encoding)
-> (FieldName a -> Bool)
-> ToJSON (FieldName a)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
forall k (a :: k). [FieldName a] -> Value
forall k (a :: k). [FieldName a] -> Encoding
forall k (a :: k). FieldName a -> Bool
forall k (a :: k). FieldName a -> Value
forall k (a :: k). FieldName a -> Encoding
$ctoJSON :: forall k (a :: k). FieldName a -> Value
toJSON :: FieldName a -> Value
$ctoEncoding :: forall k (a :: k). FieldName a -> Encoding
toEncoding :: FieldName a -> Encoding
$ctoJSONList :: forall k (a :: k). [FieldName a] -> Value
toJSONList :: [FieldName a] -> Value
$ctoEncodingList :: forall k (a :: k). [FieldName a] -> Encoding
toEncodingList :: [FieldName a] -> Encoding
$comitField :: forall k (a :: k). FieldName a -> Bool
omitField :: FieldName a -> Bool
ToJSON)


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


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


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


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


fileInput :: forall id a. View (Input id a) ()
fileInput :: forall id a. View (Input id a) ()
fileInput = do
  inp :: Input id a <- View (Input id a) (Input id a)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  tag "input" @ att "type" "file" . name inp.inputName.value $ none


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

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


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


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


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


radio :: forall id a opt. (Eq opt, ToJSON opt) => opt -> View (Radio id a opt) ()
radio :: forall id a opt.
(Eq opt, ToJSON opt) =>
opt -> View (Radio id a opt) ()
radio opt
val = do
  rd :: Radio id a opt <- View (Radio id a opt) (Radio id a opt)
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  tag "input"
    @ att "type" "radio"
    . name rd.inputName.value
    . value (encodeArgument val)
    . checked (rd.defaultOption == val)
    $ none


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


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


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

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

@
#EMBED Example.FormValidation data UserForm

#EMBED Example.FormValidation validateForm

#EMBED Example.FormValidation validateAge
@
-}

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

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

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

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


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


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


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

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


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

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

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


{- ! specify a check for a 'Validation'

@
#EMBED Example.FormValidation validateAge
@
-}

{- | specify a check for a 'Validation'

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


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

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


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


------------------------------------------------------------------------------
-- FormField
------------------------------------------------------------------------------

class FromField a where
  fromField :: Maybe FormParam -> Either String a
  default fromField :: (FromJSON a) => Maybe FormParam -> Either String a
  fromField = Maybe FormParam -> Either String a
forall a. FromJSON a => Maybe FormParam -> Either String a
argumentField


argumentField :: (FromJSON a) => Maybe FormParam -> Either String a
argumentField :: forall a. FromJSON a => Maybe FormParam -> Either String a
argumentField = \case
  Maybe FormParam
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left String
"Missing form field value"
  Just (FormParam Text
t) -> Text -> Either String a
forall a. FromJSON a => Text -> Either String a
decodeArgument Text
t
  Just (FileParam UploadedFile
_) ->
    String -> Either String a
forall a b. a -> Either a b
Left String
"Cannot parse uploaded file as param"


readField :: (Read a) => Maybe FormParam -> Either String a
readField :: forall a. Read a => Maybe FormParam -> Either String a
readField = \case
  Maybe FormParam
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left String
"Missing form field value"
  Just (FormParam Text
p) -> do
    case String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
p) of
      Maybe a
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left String
"Could not read form field"
      Just a
a -> a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Just (FileParam UploadedFile
_) ->
    String -> Either String a
forall a b. a -> Either a b
Left String
"Cannot read uploaded file as param"


instance FromField Int where
  fromField :: Maybe FormParam -> Either String Int
fromField Maybe FormParam
Nothing = Int -> Either String Int
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  fromField (Just FormParam
"") = Int -> Either String Int
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  fromField (Just FormParam
t) = Maybe FormParam -> Either String Int
forall a. Read a => Maybe FormParam -> Either String a
readField (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
t)
instance FromField Integer where
  fromField :: Maybe FormParam -> Either String Integer
fromField Maybe FormParam
Nothing = Integer -> Either String Integer
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
  fromField (Just FormParam
"") = Integer -> Either String Integer
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
  fromField (Just FormParam
t) = Maybe FormParam -> Either String Integer
forall a. Read a => Maybe FormParam -> Either String a
readField (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
t)
instance FromField Float where
  fromField :: Maybe FormParam -> Either String Float
fromField Maybe FormParam
Nothing = Float -> Either String Float
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0
  fromField (Just FormParam
"") = Float -> Either String Float
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0
  fromField (Just FormParam
t) = Maybe FormParam -> Either String Float
forall a. Read a => Maybe FormParam -> Either String a
readField (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
t)
instance FromField Double where
  fromField :: Maybe FormParam -> Either String Double
fromField Maybe FormParam
Nothing = Double -> Either String Double
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0
  fromField (Just FormParam
"") = Double -> Either String Double
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0
  fromField (Just FormParam
t) = Maybe FormParam -> Either String Double
forall a. Read a => Maybe FormParam -> Either String a
readField (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
t)


instance FromField Bool where
  fromField :: Maybe FormParam -> Either String Bool
fromField Maybe FormParam
Nothing = Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  fromField (Just (FileParam UploadedFile
_)) = String -> Either String Bool
forall a b. a -> Either a b
Left String
"Cannot parse file param as bool"
  fromField (Just (FormParam Text
p)) =
    case Text
p of
      Text
"on" -> Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Text
"off" -> Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Text
"" -> Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Text
"false" -> Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Text
"true" -> Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Text
other -> String -> Either String Bool
forall a b. a -> Either a b
Left (String -> Either String Bool) -> String -> Either String Bool
forall a b. (a -> b) -> a -> b
$ String
"Could not parse bool form param: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
other
instance FromField Char where
  fromField :: Maybe FormParam -> Either String Char
fromField Maybe FormParam
Nothing = String -> Either String Char
forall a b. a -> Either a b
Left String
"Missing form field value"
  fromField (Just (FileParam UploadedFile
_)) = String -> Either String Char
forall a b. a -> Either a b
Left String
"Cannot parse file param as Char"
  fromField (Just (FormParam Text
t)) =
    case Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
t of
      (Char
c : String
_) -> Char -> Either String Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
      String
_ -> String -> Either String Char
forall a b. a -> Either a b
Left String
"Could not parse empty form field as char"
instance FromField UTCTime where
  fromField :: Maybe FormParam -> Either String UTCTime
fromField = Maybe FormParam -> Either String UTCTime
forall a. Read a => Maybe FormParam -> Either String a
readField
instance FromField URI where
  fromField :: Maybe FormParam -> Either String URI
fromField = \case
    Maybe FormParam
Nothing -> String -> Either String URI
forall a b. a -> Either a b
Left String
"Missing form field value"
    Just (FileParam UploadedFile
_) -> String -> Either String URI
forall a b. a -> Either a b
Left String
"Cannot parse file param as Char"
    Just (FormParam Text
t) ->
      case String -> Maybe URI
parseURIReference (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
t) of
        Maybe URI
Nothing -> String -> Either String URI
forall a b. a -> Either a b
Left String
"Invalid URI"
        Just URI
a -> URI -> Either String URI
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
a
instance FromField String where
  fromField :: Maybe FormParam -> Either String String
fromField Maybe FormParam
t = (Text -> String) -> Either String Text -> Either String String
forall b c a. (b -> c) -> Either a b -> Either a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Either String Text -> Either String String)
-> Either String Text -> Either String String
forall a b. (a -> b) -> a -> b
$ forall a. FromField a => Maybe FormParam -> Either String a
fromField @Text Maybe FormParam
t
instance FromField BS.ByteString where
  fromField :: Maybe FormParam -> Either String ParamKey
fromField Maybe FormParam
t = (Text -> ParamKey) -> Either String Text -> Either String ParamKey
forall b c a. (b -> c) -> Either a b -> Either a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> ParamKey
forall a b. ConvertibleStrings a b => a -> b
cs (Either String Text -> Either String ParamKey)
-> Either String Text -> Either String ParamKey
forall a b. (a -> b) -> a -> b
$ forall a. FromField a => Maybe FormParam -> Either String a
fromField @Text Maybe FormParam
t
instance FromField Text where
  fromField :: Maybe FormParam -> Either String Text
fromField = \case
    Maybe FormParam
Nothing -> Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
""
    Just (FormParam Text
t) -> Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
    Just (FileParam UploadedFile
_) -> String -> Either String Text
forall a b. a -> Either a b
Left String
"Cannot parse FileParam as Text"


instance {-# OVERLAPPABLE #-} (FromField a) => FromField (Maybe a) where
  fromField :: Maybe FormParam -> Either String (Maybe a)
fromField Maybe FormParam
Nothing = Maybe a -> Either String (Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  fromField (Just FormParam
"") = Maybe a -> Either String (Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  fromField (Just FormParam
a) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromField a => Maybe FormParam -> Either String a
fromField @a (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
a)
instance {-# OVERLAPS #-} FromField (Maybe BS.ByteString) where
  fromField :: Maybe FormParam -> Either String (Maybe ParamKey)
fromField Maybe FormParam
Nothing = Maybe ParamKey -> Either String (Maybe ParamKey)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ParamKey
forall a. Maybe a
Nothing
  fromField (Just FormParam
"") = Maybe ParamKey -> Either String (Maybe ParamKey)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ParamKey -> Either String (Maybe ParamKey))
-> Maybe ParamKey -> Either String (Maybe ParamKey)
forall a b. (a -> b) -> a -> b
$ ParamKey -> Maybe ParamKey
forall a. a -> Maybe a
Just ParamKey
""
  fromField (Just FormParam
a) = ParamKey -> Maybe ParamKey
forall a. a -> Maybe a
Just (ParamKey -> Maybe ParamKey)
-> Either String ParamKey -> Either String (Maybe ParamKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromField a => Maybe FormParam -> Either String a
fromField @BS.ByteString (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
a)
instance {-# OVERLAPS #-} FromField (Maybe Text) where
  fromField :: Maybe FormParam -> Either String (Maybe Text)
fromField Maybe FormParam
Nothing = Maybe Text -> Either String (Maybe Text)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
  fromField (Just FormParam
"") = Maybe Text -> Either String (Maybe Text)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Either String (Maybe Text))
-> Maybe Text -> Either String (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
  fromField (Just FormParam
a) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> Either String Text -> Either String (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromField a => Maybe FormParam -> Either String a
fromField @Text (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
a)
instance {-# OVERLAPS #-} FromField (Maybe String) where
  fromField :: Maybe FormParam -> Either String (Maybe String)
fromField Maybe FormParam
Nothing = Maybe String -> Either String (Maybe String)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  fromField (Just FormParam
"") = Maybe String -> Either String (Maybe String)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> Either String (Maybe String))
-> Maybe String -> Either String (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
""
  fromField (Just FormParam
a) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> Either String String -> Either String (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromField a => Maybe FormParam -> Either String a
fromField @String (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
a)
instance {-# OVERLAPPABLE #-} (FromField a, FromField b) => FromField (Either a b) where
  fromField :: Maybe FormParam -> Either String (Either a b)
fromField = \case
    Maybe FormParam
Nothing -> String -> Either String (Either a b)
forall a b. a -> Either a b
Left String
"Missing form field value"
    Just FormParam
p ->
      case forall a. FromField a => Maybe FormParam -> Either String a
fromField @a (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
p) of
        Right a
a -> Either a b -> Either String (Either a b)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> Either String (Either a b))
-> Either a b -> Either String (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
a
        Left String
_ -> b -> Either a b
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either a b) -> Either String b -> Either String (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromField a => Maybe FormParam -> Either String a
fromField @b (FormParam -> Maybe FormParam
forall a. a -> Maybe a
Just FormParam
p)
instance FromField UploadedFile where
  fromField :: Maybe FormParam -> Either String UploadedFile
fromField = \case
    Maybe FormParam
Nothing -> String -> Either String UploadedFile
forall a b. a -> Either a b
Left String
"Missing file upload"
    Just (FormParam Text
"") -> String -> Either String UploadedFile
forall a b. a -> Either a b
Left String
"Missing file upload"
    Just (FormParam Text
t) -> String -> Either String UploadedFile
forall a b. a -> Either a b
Left (String -> Either String UploadedFile)
-> String -> Either String UploadedFile
forall a b. (a -> b) -> a -> b
$ String
"Cannot parse FormParam as UploadedFile: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
t
    Just (FileParam UploadedFile
f) ->
      if UploadedFile
f.fileName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty
        then String -> Either String UploadedFile
forall a b. a -> Either a b
Left String
"Empty file uploaded"
        else UploadedFile -> Either String UploadedFile
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UploadedFile
f
instance {-# OVERLAPS #-} FromField (Maybe UploadedFile) where
  fromField :: Maybe FormParam -> Either String (Maybe UploadedFile)
fromField = \case
    Maybe FormParam
Nothing -> Maybe UploadedFile -> Either String (Maybe UploadedFile)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UploadedFile
forall a. Maybe a
Nothing
    Just (FileParam UploadedFile
f) -> do
      if UploadedFile
f.fileName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty
        then Maybe UploadedFile -> Either String (Maybe UploadedFile)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UploadedFile
forall a. Maybe a
Nothing
        else Maybe UploadedFile -> Either String (Maybe UploadedFile)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UploadedFile -> Either String (Maybe UploadedFile))
-> Maybe UploadedFile -> Either String (Maybe UploadedFile)
forall a b. (a -> b) -> a -> b
$ UploadedFile -> Maybe UploadedFile
forall a. a -> Maybe a
Just UploadedFile
f
    Maybe FormParam
other -> Maybe FormParam -> Either String (Maybe UploadedFile)
forall a. FromField a => Maybe FormParam -> Either String a
fromField Maybe FormParam
other


-- these instances don't make a lot of sense
-- instance (FromField a, FromField b) => FromField (a, b)
-- instance (FromField a, FromField b, FromField c) => FromField (a, b, c)
-- instance {-# OVERLAPPABLE #-} (FromParam a) => FromField [a]
-- instance FromField Value
-- instance FromField Word
-- instance FromField Word8
-- instance FromField Word16
-- instance FromField Word32
-- instance FromField Word64

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

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


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


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


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


instance (Selector s, FromField a) => GFormParse (M1 S s (K1 R a)) where
  gFormParse :: forall (p :: k). Form -> Either String (M1 S s (K1 R a) p)
gFormParse Form
f = do
    let sel :: String
sel = M1 S s (K1 R (ZonkAny 8 a)) (ZonkAny 7) -> 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)
    a <- ParamKey -> Form -> Either String a
forall a. FromField a => ParamKey -> Form -> Either String a
parseField (String -> ParamKey
forall a b. ConvertibleStrings a b => a -> b
cs String
sel) Form
f
    pure $ M1 $ K1 a


-- class GFieldParse f where
--   gFieldParse :: String -> Maybe ParamValue -> Either String (f p)
--
--
-- instance {-# OVERLAPPABLE #-} (FromJSON a) => GFieldParse (K1 R a) where
--   gFieldParse sel Nothing = Left $ "Missing form field: " <> sel
--   gFieldParse _ (Just (ParamText t)) = K1 <$> decodeArgument t
--   gFieldParse sel (Just _) = Left $ "Unexpected file param: " <> sel
--
--
-- instance {-# OVERLAPS #-} (GFieldParse (K1 R a)) => GFieldParse (K1 R (Maybe a)) where
--   gFieldParse _ Nothing = pure $ K1 Nothing
--   gFieldParse _ (Just (ParamText "")) = pure $ K1 Nothing -- an empty string should be Nothing unless overriden
--   gFieldParse sel (Just p) = do
--     K1 a <- gFieldParse @(K1 R a) sel (Just p)
--     pure $ K1 $ Just a
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R Bool) where
--   gFieldParse _ Nothing = pure $ K1 False
--   gFieldParse sel (Just t) = do
--     K1 <$> case t of
--       "on" -> pure True
--       "off" -> pure False
--       "" -> pure False
--       "false" -> pure False
--       "true" -> pure True
--       ParamText other -> Left $ "Could not parse bool field: " <> sel <> " = " <> cs other
--       ParamFile _ -> Left $ "Unexpected file param: " <> sel
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R (Maybe Text)) where
--   gFieldParse _ Nothing = pure $ K1 Nothing
--   gFieldParse sel inp = do
--     K1 t <- gFieldParse @(K1 R Text) sel inp
--     pure $ K1 $ Just t
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R Text) where
--   gFieldParse _ Nothing = pure $ K1 ""
--   gFieldParse _ (Just "") = pure $ K1 ""
--   gFieldParse _ (Just (ParamText t)) = K1 <$> decodeArgument ("\"" <> t <> "\"")
--   gFieldParse sel (Just _) = Left $ "Unexpected file param: " <> sel
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R Int) where
--   gFieldParse _ Nothing = pure $ K1 0
--   gFieldParse _ (Just "") = pure $ K1 0
--   gFieldParse _ (Just (ParamText t)) = K1 <$> decodeArgument t
--   gFieldParse sel (Just _) = Left $ "Unexpected file param: " <> sel
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R Integer) where
--   gFieldParse _ Nothing = pure $ K1 0
--   gFieldParse _ (Just "") = pure $ K1 0
--   gFieldParse _ (Just (ParamText t)) = K1 <$> decodeArgument t
--   gFieldParse sel (Just _) = Left $ "Unexpected file param: " <> sel
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R Float) where
--   gFieldParse _ Nothing = pure $ K1 0
--   gFieldParse _ (Just "") = pure $ K1 0
--   gFieldParse _ (Just (ParamText t)) = K1 <$> decodeArgument t
--   gFieldParse sel (Just _) = Left $ "Unexpected file param: " <> sel
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R Double) where
--   gFieldParse _ Nothing = pure $ K1 0
--   gFieldParse _ (Just "") = pure $ K1 0
--   gFieldParse _ (Just (ParamText t)) = K1 <$> decodeArgument t
--   gFieldParse sel (Just _) = Left $ "Unexpected file param: " <> sel
--
--
-- instance {-# OVERLAPS #-} GFieldParse (K1 R UploadedFile) where
--   gFieldParse sel Nothing = Left $ "Missing form field: " <> sel
--   gFieldParse _ (Just (ParamFile f)) = Right $ K1 f
--   gFieldParse sel (Just (ParamText _)) = Left $ "Unexpected text param: " <> sel

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

class GFieldsGen f where
  gFieldsGen :: f p


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


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


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

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


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


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

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

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

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

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

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

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

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