Multiple View Updates

MultiViews.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}

module Woot where

import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Web.Hyperbole


main = do
  run 3000 $ do
    liveApp (basicDocument "Skeleton") (page centralPage)


data Central = Central
  deriving (Show, Read, ViewId)


data CentralAction
  = ChangeSelectedTo Selected
  | ViewResults Selected ResultVariant
  deriving (Show, Read, ViewAction)


data Selected = A | B | C deriving (Show, Eq, Read)


instance HyperView Central where
  type Action Central = CentralAction
  type Require Central = '[Sidebar]


central :: Central -> CentralAction -> Eff es (View Central ())
central _ (ChangeSelectedTo x) = pure $ centralView x Nothing
central _ (ViewResults x r) = pure $ centralView x (Just r)


centralPage :: (Hyperbole :> es) => Page es '[Central, Sidebar]
centralPage = do
  -- message listens for any actions that the centralView triggers
  handle central $ handle sidebar $ load $ do
    pure $ do
      el bold "Message Page"
      row (border 3 . pad 10 . gap 10) $ do
        hyper (Sidebar 1) $ sidebarView Nothing
        hyper Central $ centralView A Nothing
        hyper (Sidebar 2) $ sidebarView Nothing


centralView :: Selected -> Maybe ResultVariant -> View Central ()
centralView s mr = do
  col (border 3 . pad 10) $ do
    el_ $ text ("Selected: " `T.append` T.pack (show s))
    button (ChangeSelectedTo A) id "A"
    button (ChangeSelectedTo B) id "B"
    button (ChangeSelectedTo C) id "C"
    col (border 3 . pad 10 . gap 10) $ do
      presetsView s
      resultsView s mr


presetsView :: Selected -> View Central ()
presetsView s = do
  col (border 3 . pad 10) $ do
    el (fontSize 18) "Presets"
    text $ "viewing details for " `T.append` T.pack (show s)
    let variant x t = button (ViewResults s x) id t
    case s of
      A -> col id $ variant Result1 "Result1"
      B -> col id $ do
        variant Result2 "Result2"
        variant Result3 "Result3"
      C -> col id $ do
        variant Result4 "Result4"
        variant Result5 "Result5"
        variant Result6 "Result6"


data ResultVariant = Result1 | Result2 | Result3 | Result4 | Result5 | Result6 | Result7 | Result8 deriving (Show, Eq, Read)


resultsView :: Selected -> Maybe ResultVariant -> View Central ()
resultsView _ Nothing = col (border 3 . pad 10) $ el_ $ text "no results!"
resultsView sel (Just x) = col (border 3 . pad 10) $
  case x of
    Result1 -> text "one short result"
    Result2 -> text "a different result"
    Result3 -> text "this is a special result"
    Result4 -> text "THIS IS NUUMBER FOOOUR!"
    Result5 -> text "give me a high five"
    Result6 -> do
      target (Sidebar 1) $ button (UpdateSidebar (Just "surprise!!")) id "click me to get surprise in sidebar"
    Result7 -> do
      onLoad (ViewResults sel Result8) 1000 $ do
        el_ "loading…"

      -- Why are we lazily loading these?
      target (Sidebar 2) $ onLoad (UpdateSidebar (Just "unlocking secret chamber…")) 0 (el_ "loading…")
      target (Sidebar 1) $ onLoad (UpdateSidebar (Just "wohoo! you did it!")) 0 (el_ "loading…")
    Result8 -> text "you unlocked the secret chamber"


data Sidebar = Sidebar Int
  deriving (Show, Read, ViewId)


data SidebarAction = UpdateSidebar (Maybe Text)
  deriving (Show, Read, ViewAction)


instance HyperView Sidebar where
  type Action Sidebar = SidebarAction


sidebar :: Sidebar -> SidebarAction -> Eff es (View Sidebar ())
sidebar _ (UpdateSidebar x) = pure $ sidebarView x


sidebarView :: Maybe Text -> View Sidebar ()
sidebarView x = col (border 3 . pad 10) $ do
  text $ fromMaybe "N/A" x
  case x of
    -- WARNING: we are assuming we want the sidebar to stay in C when they click the sercret
    Just "surprise!!" -> target Central $ button (ViewResults C Result7) id "set to Result7"
    Just _ -> none
    Nothing -> none