Contacts.hs

module Example.Contacts where

import Control.Monad (forM_)
import Data.String.Conversions
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic
import Example.Colors
import Example.Effects.Debug
import Example.Effects.Users (User (..), Users)
import Example.Effects.Users qualified as Users
import GHC.Generics (Generic)
import Web.Hyperbole


page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Page es ()
page = do
  hyper contacts
  hyper contact
  load $ do
    us <- usersAll
    pure $ do
      col (pad 10 . gap 10) $ do
        viewId Contacts $ allContactsView Nothing us


-- Contacts ----------------------------------------------

data Contacts = Contacts
  deriving (Show, Read, Param)


data ContactsAction
  = Reload (Maybe Filter)
  | Delete Int
  deriving (Show, Read, Param)


instance HyperView Contacts where
  type Action Contacts = ContactsAction


data Filter
  = Active
  | Inactive
  deriving (Show, Read, Eq)


contacts :: (Hyperbole :> es, Users :> es, Debug :> es) => Contacts -> ContactsAction -> Eff es (View Contacts ())
contacts _ (Reload mf) = do
  us <- usersAll
  pure $ allContactsView mf us
contacts _ (Delete uid) = do
  userDelete uid
  us <- usersAll
  pure $ allContactsView Nothing us


allContactsView :: Maybe Filter -> [User] -> View Contacts ()
allContactsView fil us = do
  row (gap 10) $ do
    button (Reload Nothing) (bg GrayLight) "Reload"

    dropdown Reload (== fil) id $ do
      option Nothing ""
      option (Just Active) "Active!"
      option (Just Inactive) "Inactive"

    target (Contact 2) $ button Edit (bg GrayLight) "Edit 2"

  row (pad 10 . gap 10) $ do
    let filtered = filter (filterUsers fil) us
    forM_ filtered $ \u -> do
      el (border 1) $ do
        viewId (Contact u.id) $ contactView u
 where
  filterUsers Nothing _ = True
  filterUsers (Just Active) u = u.isActive
  filterUsers (Just Inactive) u = not u.isActive


-- Contact ----------------------------------------------------

data Contact = Contact Int
  deriving (Show, Read, Param)


data ContactAction
  = Edit
  | Save
  | View
  deriving (Show, Read, Param)


instance HyperView Contact where
  type Action Contact = ContactAction


data UserForm a = UserForm
  { firstName :: Field a Text
  , lastName :: Field a Text
  , age :: Field a Int
  }
  deriving (Generic, Form)


contact :: (Hyperbole :> es, Users :> es, Debug :> es) => Contact -> ContactAction -> Eff es (View Contact ())
contact (Contact uid) a = do
  u <- userFind uid
  action u a
 where
  action u View = do
    pure $ contactView u
  action u Edit = do
    pure $ contactEdit u
  action u Save = do
    delay 1000
    UserForm{firstName, lastName, age} <- parseForm
    let u' = User{id = u.id, isActive = True, firstName, lastName, age}
    userSave u'
    pure $ contactView u'


contactView :: User -> View Contact ()
contactView u = do
  col (pad 10 . gap 10) $ do
    row fld $ do
      el id (text "First Name:")
      text u.firstName

    row fld $ do
      el id (text "Last Name:")
      text u.lastName

    row fld $ do
      el id (text "Age:")
      text (cs $ show u.age)

    row fld $ do
      el id (text "Active:")
      text (cs $ show u.isActive)

    button Edit (bg Primary . color White . hover (bg PrimaryLight . color Dark)) "Edit"
 where
  fld = gap 10


contactEdit :: User -> View Contact ()
contactEdit u =
  onRequest loading $ do
    form @UserForm Save (pad 10 . gap 10) $ \f -> do
      field fld $ do
        label "First Name:"
        input Name (value u.firstName) f.firstName

      field fld $ do
        label "Last Name:"
        input Name (value u.lastName) f.lastName

      field fld $ do
        label "Age:"
        input Number (value $ cs $ show u.age) f.age

      submit id "Submit"

      button View id (text "Cancel")

      target Contacts $ button (Delete u.id) (bg Secondary) (text "Delete")
 where
  loading = el (bg Secondary) "Loading..."
  fld = flexRow . gap 10


userFind :: (Hyperbole :> es, Users :> es) => Int -> Eff es User
userFind uid = do
  mu <- send (Users.LoadUser uid)
  maybe notFound pure mu


usersAll :: (Users :> es) => Eff es [User]
usersAll = send Users.LoadUsers


userSave :: (Users :> es) => User -> Eff es ()
userSave = send . Users.SaveUser


userDelete :: (Users :> es) => Int -> Eff es ()
userDelete = send . Users.DeleteUser