Forms.hs

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

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

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

import Data.Bifunctor (first)
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 Effectful
import GHC.Generics
import Text.Casing (kebab)
import Web.Atomic.Types hiding (Selector)
import Web.FormUrlEncoded (Form (..), FormOptions (..))
import Web.FormUrlEncoded qualified as FE
import Web.Hyperbole.Data.Param
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Request
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.HyperView.ViewAction
import Web.Hyperbole.View


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

{- | Simple types that be decoded from form data

@
#EMBED Example/Page/FormSimple.hs data ContactForm
@
-}
class FromForm (form :: Type) where
  fromForm :: FE.Form -> Either String form
  default fromForm :: (Generic form, GFormParse (Rep form)) => FE.Form -> Either String form
  fromForm f = to <$> gFormParse f


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

@
#EMBED Example/Page/FormValidation.hs data UserForm
@
-}
class FromFormF (f :: (Type -> Type) -> Type) where
  fromFormF :: FE.Form -> Either String (f Identity)
  default fromFormF :: (Generic (f Identity), GFormParse (Rep (f Identity))) => FE.Form -> Either String (f Identity)
  fromFormF f = to <$> gFormParse 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 = fromFormF


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


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

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

@
#EMBED Example/Page/FormValidation.hs data UserForm
@

@
#EMBED Example/Page/Contacts.hs newContactForm
@
-}
class GenFields f (form :: (Type -> Type) -> Type) where
  genFields :: form f
  default genFields :: (Generic (form f), GFieldsGen (Rep (form f))) => form f
  genFields = to gFieldsGen


{- | Generate FieldNames for a form

#EXAMPLE /forms

> #EMBED Example/Page/Todos/Todo.hs data TodoForm
>
> #EMBED Example/Page/Todos/Todo.hs todoForm
-}
fieldNames :: forall form. (GenFields FieldName form) => form FieldName
fieldNames = genFields


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


instance GenField (FieldName a) where
  genField s = FieldName $ pack s


instance GenField (Validated a) where
  genField = const NotInvalid


instance GenField (Maybe a) where
  genField _ = Nothing


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

-- | Context that allows form fields
data FormFields id = FormFields id


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

@
#EMBED Example/Page/FormSimple.hs formView
@
-}
form :: (ViewAction (Action id)) => Action id -> View (FormFields id) () -> View id ()
form a cnt = do
  vid <- context
  tag "form" @ onSubmit a $ do
    addContext (FormFields vid) cnt


-- | Button that submits the 'form'
submit :: View (FormFields id) () -> View (FormFields id) ()
submit = tag "button" @ att "type" "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 Text
  deriving newtype (Show, IsString)


-- | Display a 'FormField'. See 'form' and 'Form'
field
  :: forall (id :: Type) (a :: Type)
   . FieldName a
  -> View (Input id a) ()
  -> View (FormFields id) ()
field fn =
  addContext (Input 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 (Show)


data Input (id :: Type) (a :: Type) = Input
  { inputName :: FieldName a
  }


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


-- | input for a 'field'
input :: InputType -> View (Input id a) ()
input ft = do
  Input (FieldName nm) <- context
  tag "input" @ att "type" (inpType ft) . name nm . att "autocomplete" (auto ft) $ none
 where
  inpType NewPassword = "password"
  inpType CurrentPassword = "password"
  inpType Number = "number"
  inpType Email = "email"
  inpType Search = "search"
  inpType _ = "text"

  auto :: InputType -> Text
  auto = pack . kebab . show


checkbox :: Bool -> View (Input id a) ()
checkbox isChecked = do
  Input (FieldName nm) <- context
  tag "input" @ att "type" "checkbox" . name nm $ none @ checked isChecked


-- 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) (b :: Type) = Selection
  { inputCtx :: Input id a
  , defaultOption :: b
  }


radioGroup :: b -> View (Radio id a b) () -> View (Input id a) ()
radioGroup defOpt = modifyContext $ \inp -> Selection inp defOpt


radio :: (Eq b, ToParam b) => b -> View (Radio id a b) ()
radio val = do
  Selection (Input (FieldName nm)) defOpt <- context
  tag "input"
    @ att "type" "radio"
    . name nm
    . value (toParam val).value
    . checked (defOpt == val)
    $ none


select :: (Eq opt) => opt -> View (Option opt id) () -> View (Input id a) ()
select defOpt options = do
  Input (FieldName nm) <- context
  tag "select" @ name nm $ addContext (Option defOpt) options


-- | textarea for a 'field'
textarea :: Maybe Text -> View (Input id a) ()
textarea mDefaultText = do
  Input (FieldName nm) <- context
  tag "textarea" @ name nm $ text $ fromMaybe "" mDefaultText


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

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

@
#EMBED Example/Page/FormValidation.hs data UserForm

#EMBED Example/Page/FormValidation.hs validateForm

#EMBED Example/Page/FormValidation.hs validateAge
@
-}
data Validated a = Invalid Text | NotInvalid | Valid
  deriving (Show)


instance Semigroup (Validated a) where
  Invalid t <> _ = Invalid t
  _ <> Invalid t = Invalid t
  Valid <> _ = Valid
  _ <> Valid = Valid
  a <> _ = a


instance Monoid (Validated a) where
  mempty = 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 (Invalid _) = True
isInvalid _ = 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 v = do
  case v of
    Invalid t -> text t
    _ -> none


{- | specify a check for a 'Validation'

@
#EMBED Example/Page/FormValidation.hs validateAge
@
-}
validate :: Bool -> Text -> Validated a
validate True t = Invalid t -- Validation [(inputName @a, Invalid t)]
validate False _ = 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


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

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


instance (GFormParse f, GFormParse g) => GFormParse (f :*: g) where
  gFormParse f = do
    a <- gFormParse f
    b <- gFormParse f
    pure $ a :*: b


instance (GFormParse f) => GFormParse (M1 D d f) where
  gFormParse f = M1 <$> gFormParse f


instance (GFormParse f) => GFormParse (M1 C c f) where
  gFormParse f = M1 <$> gFormParse f


-- TODO: need a bool instance?
-- TODO: need a Maybe a instance?
instance (Selector s, FromParam a) => GFormParse (M1 S s (K1 R a)) where
  -- these CANNOT be json encoded, they are encoded by the browser
  gFormParse f = do
    let sel = selName (undefined :: M1 S s (K1 R (f a)) p)
    mt :: Maybe Text <- first cs $ FE.lookupMaybe (cs sel) f
    a <- first (\err -> sel <> ": " <> err) $ decodeFormValue mt
    pure $ M1 . K1 $ a


-- instance {-# OVERLAPPING #-} (Selector s, FromParam a) => GFormParse (M1 S s (K1 R (Maybe a))) where
--   gFormParse f = do
--     let sel = selName (undefined :: M1 S s (K1 R (f a)) p)
--     mt :: Maybe Text <- first cs $ FE.lookupMaybe (cs sel) f
--     ma :: Maybe a <- maybe (pure Nothing) (parseParam . decodeParam) mt
--     pure $ M1 . K1 $ ma

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

class GFieldsGen f where
  gFieldsGen :: f p


instance GFieldsGen U1 where
  gFieldsGen = U1


instance (GFieldsGen f, GFieldsGen g) => GFieldsGen (f :*: g) where
  gFieldsGen = gFieldsGen :*: 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 =
    let sel = selName (undefined :: M1 S s (K1 R (f a)) p)
     in M1 . K1 $ genField @a sel


instance (GFieldsGen f) => GFieldsGen (M1 D d f) where
  gFieldsGen = M1 gFieldsGen


instance (GFieldsGen f) => GFieldsGen (M1 C c f) where
  gFieldsGen = M1 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

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

-- newtype User = User Text
--   deriving newtype (FromParam)
--
--
-- data TestForm f = TestForm
--   { name :: Field f Text
--   , age :: Field f Int
--   , user :: Field f User
--   }
--   deriving (Generic, FromFormF, GenFields Maybe, GenFields Validated)

-- test :: (Hyperbole :> es) => Eff es (TestForm Identity)
-- test = do
--   tf <- formData
--   pure tf

-- formView :: (ViewAction (Action id)) => View id ()
-- formView = do
--   -- generate a ContactForm' FieldName
--   let f = fieldNames @ContactForm
--   form undefined (gap 10 . pad 10) $ do
--     -- f.name :: FieldName Text
--     -- f.name = FieldName "name"
--     field f.name id $ do
--       label "Contact Name"
--       input Username (placeholder "contact name")
--
--     -- f.age :: FieldName Int
--     -- f.age = FieldName "age"
--     field f.age id $ do
--       label "Age"
--       input Number (placeholder "age" . value "0")
--
--     submit id "Submit"
--
--
-- formView' :: (ViewAction (Action id)) => ContactForm Validated -> View id ()
-- formView' contact = do
--   -- generate a ContactForm' FieldName
--   let f = formFields @ContactForm contact
--   form undefined (gap 10 . pad 10) $ do
--     -- f.name :: FieldName Text
--     -- f.name = FieldName "name"
--     field f.name id $ do
--       label "Contact Name"
--       input Username (placeholder "contact name")
--
--     -- f.age :: FieldName Int
--     -- f.age = FieldName "age"
--     field f.age id $ do
--       label "Age"
--       input Number (placeholder "age" . value "0")
--
--     field f.age id $ do
--       label "Username"
--       input Username (placeholder "username")
--
--     case f.age.value of
--       Invalid t -> el_ (text t)
--       Valid -> el_ "Username is available"
--       _ -> none
--
--     submit id "Submit"
--  where
--   valStyle (Invalid _) = id
--   valStyle Valid = id
--   valStyle _ = id
--
--
-- data ContactForm' = ContactForm'
--   { name :: Text
--   , age :: Int
--   }
--   deriving (Generic)
-- instance FormParse ContactForm'
--
--
-- formView'' :: (ViewAction (Action id)) => View id ()
-- formView'' = do
--   form undefined (gap 10 . pad 10) $ do
--     -- f.name :: FieldName Text
--     -- f.name = FieldName "name"
--     field (FieldName "name") id $ do
--       label "Contact Name"
--       input Username (placeholder "contact name")