nano-ui-form-0.1.0.0: examples/FormDemo.hs

-- | A registration form with validated fields and a view of the value it
-- decodes to.
module FormDemo (formDemoUi) where

import Control.Monad (forM_, when)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Ditto.Types as Ditto
import NanoUI
  ( Color
  , NanoUI
  , button
  , card
  , colorToHex
  , colorRGBA
  , columnWith
  , danger
  , fillW
  , flex
  , fontMono
  , gap
  , grow
  , heading
  , kv
  , labelWith
  , maxW
  , minW
  , muted
  , padAll
  , rowWith
  , scrollWith
  , separator
  , tight
  , toolbar
  , useText
  )
import NanoUI.Form
  ( Form
  , FormView (..)
  , inRange
  , inputCheckbox
  , inputColor
  , inputEnumSelect
  , inputPassword
  , inputSlider
  , inputTextArea
  , inputTextWithPlaceholder
  , maxLength
  , minLength
  , notEmpty
  , prove
  , resetForm
  , runNanoForm
  , validEmail
  , withFieldErrors
  )

-- | Account tiers, picked with an enum select.
data AccountTier = Starter | Developer | Professional | Enterprise
  deriving (Eq, Show, Bounded, Enum)

-- | The value the form decodes to.
data Registration = Registration
  { regUsername   :: !Text
  , regEmail      :: !Text
  , regPassword   :: !Text
  , regAge        :: !Float
  , regTier       :: !AccountTier
  , regThemeColor :: !Color
  , regSubscribe  :: !Bool
  , regBio        :: !Text
  } deriving (Eq, Show)

-- | One validated field for each 'Registration' field.
registrationForm :: Form Text Registration
registrationForm =
  Registration
    <$> withFieldErrors
          (inputTextWithPlaceholder "e.g. adalovelace" "Username" "Ada"
            `prove` notEmpty "Username is required"
            `prove` minLength 3 (const "Must be at least 3 characters")
            `prove` maxLength 20 (const "Must be 20 characters or fewer"))
    <*> withFieldErrors
          (inputTextWithPlaceholder "e.g. ada@example.com" "Email" "ada@example.com"
            `prove` notEmpty "Email address is required"
            `prove` validEmail (const "Invalid email address format (e.g. name@domain.com)"))
    <*> withFieldErrors
          (inputPassword "Password" "correcthorse"
            `prove` notEmpty "Password is required"
            `prove` minLength 8 (const "Password must be at least 8 characters long"))
    <*> withFieldErrors
          (inputSlider "Age" 13 100 28
            `prove` inRange 18 100 (const "Must be at least 18 years old for this account tier"))
    <*> inputEnumSelect "Account Tier" Developer
    <*> inputColor "Accent Color" (colorRGBA 99 102 241 255)
    <*> inputCheckbox "Subscribe to release announcements and updates" True
    <*> withFieldErrors
          (inputTextArea "Developer Bio" "Writes GUI applications in Haskell with nano-ui and ditto."
            `prove` maxLength 160 (const "Bio must be 160 characters or fewer"))

formatRegistration :: Registration -> Text
formatRegistration r =
  "User @" <> regUsername r <> " (" <> regEmail r <> "), Age: "
    <> T.pack (show (round (regAge r) :: Int))
    <> ", Tier: " <> T.pack (show (regTier r))
    <> ", Color: " <> colorToHex (regThemeColor r)
    <> ", Subscribed: " <> (if regSubscribe r then "Yes" else "No")

formDemoUi :: NanoUI ()
formDemoUi = do
  (submittedMsg, setSubmitted) <- useText ""
  (view', res) <- runNanoForm "user_reg" registrationForm
  let mReg = case res of
        Ditto.Ok (Ditto.Proved _ a) -> Just a
        Ditto.Error _               -> Nothing
      renderedView = case res of
        Ditto.Error errs -> Ditto.unView view' errs
        Ditto.Ok _       -> Ditto.unView view' []
  scrollWith (tight . grow) $
    columnWith (padAll 20 . gap 16 . fillW) $ do
      toolbar $ do
        columnWith (tight . gap 2) $ do
          heading "nano-ui-form"
          muted "Forms built with ditto, drawn with nano-ui"
        flex
        muted "Press ESC to exit"
      separator
      rowWith (tight . gap 20 . fillW) $ do
        columnWith (tight . gap 12 . fillW) $ do
          card $ do
            heading "User Profile & Registration"
            muted "Fields validate as you type."
            separator
            runFormView renderedView
            separator
            rowWith (tight . gap 10 . fillW) $ do
              btnSubmit <- button "Submit Registration"
              btnReset  <- button "Reset Form"
              when btnSubmit $ do
                case mReg of
                  Just reg -> setSubmitted ("Successfully registered: " <> formatRegistration reg)
                  Nothing  -> setSubmitted "Submission failed: Please fix the highlighted validation errors."
              when btnReset $ do
                resetForm "user_reg"
                setSubmitted "Form has been reset to defaults."

        columnWith (tight . gap 12 . minW 340 . maxW 380) $ do
          card $ do
            heading "Decoded value"
            muted "The registration the form decodes to, or its errors."
            separator
            case res of
              Ditto.Ok (Ditto.Proved _ reg) -> do
                heading "Status: VALID"
                separator
                kv "Username" (regUsername reg)
                kv "Email" (regEmail reg)
                kv "Age" (T.pack (show (round (regAge reg) :: Int)) <> " years old")
                kv "Account Tier" (T.pack (show (regTier reg)))
                kv "Color Hex" (colorToHex (regThemeColor reg))
                kv "Newsletter" (if regSubscribe reg then "Active" else "Inactive")
                separator
                columnWith (tight . gap 4 . fillW) $ do
                  muted "Bio:"
                  labelWith (tight . fillW . maxW 350 . fontMono) (regBio reg)
              Ditto.Error errs -> do
                danger "Status: INVALID / INCOMPLETE"
                separator
                heading "Active Validation Errors:"
                forM_ errs $ \(_, errMsg) -> do
                  danger ("• " <> errMsg)

          card $ do
            heading "Submission Activity"
            muted "Record of last form submission:"
            separator
            if T.null submittedMsg
              then muted "No submission attempted yet."
              else labelWith (tight . fillW . maxW 350 . fontMono) submittedMsg