route generates unintuitive default link for first entry

[benjaminweb]

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

module Table where

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

router :: (Hyperbole :> es) => AppRoute -> Eff es Response
router Main = page $ centralPage Nothing
router (ResultRequested x) = page $ centralPage (Just x)
router Query = do
  p <- reqParam "key"
  view $ el (pad 20) $ do
    text "key: "
    text p

data AppRoute = Main | ResultRequested ResultVariant | Query deriving (Generic, Eq, Route)

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

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

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

instance HyperView Central where
  type Action Central = CentralAction
  type Require Central = '[Presets, Results]

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

centralPage :: (Hyperbole :> es) => Maybe ResultVariant -> Page es '[Central, Presets, Results]
centralPage v = do
  -- message listens for any actions that the centralView triggers
  handle central $ handle presets $ handle results $ load $ do
    pure $ do
      el bold "Message Page"
      hyper Central $ centralView A v

createNavButton :: Selected -> Selected -> View Central ()
createNavButton currentSelected changeTo = button (ChangeSelectedTo changeTo) btnStyle $ text $ T.pack $ show changeTo
  where btnStyle | currentSelected == changeTo = Style.btn' Colors.Secondary
                 | otherwise = Style.btn' Colors.Primary

centralView :: Selected -> Maybe ResultVariant -> View Central ()
centralView s v = do
  col (border 3 . pad 10 . gap 10) $ do
    row (gap 10) $ do
      el_ $ text "Please select group:"
      createNavButton s A 
      createNavButton s B
      createNavButton s C
    col (border 3 . pad 10 . gap 10) $ do
      hyper Presets $ presetsView s
      hyper Results $ resultsView v

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

data PresetsAction = View Selected deriving (Show, Read, ViewAction)

instance HyperView Presets where
  type Action Presets = PresetsAction

presets :: (Hyperbole :> es) => Presets -> PresetsAction -> Eff es (View Presets ())
presets _ (View s) = pure $ presetsView s

presetGroup :: [ResultVariant] -> View Presets ()
presetGroup = foldl1 (>>) . map presetTarget

presetTarget :: ResultVariant -> View Presets ()
presetTarget x = target Results $ button (ViewResults $ Just x) Style.btn $ text $ T.pack $ show x
--presetTarget x = route (ResultRequested x) id $ text $ T.pack $ show x

presetsView :: Selected -> View Presets ()
presetsView s = do
  col (border 3 . pad 30 . gap 30) $ do
    text $ "presetsView: viewing details for " `T.append` T.pack (show s)
    col (pad 10 . gap 10) $ case s of
      A -> presetGroup [Result1]
      B -> presetGroup [Result1, Result3]
      C -> presetGroup [Result4, Result5, Result6]

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

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

data ResultsAction = ViewResults (Maybe ResultVariant) deriving (Show, Read, ViewAction)

instance HyperView Results where
  type Action Results = ResultsAction

results :: (Hyperbole :> es) => Results -> ResultsAction -> Eff es (View Results ())
results _ (ViewResults x) = pure $ resultsView x

resultsView :: Maybe ResultVariant -> View Results ()
resultsView Nothing = col (border 3 . pad 10) $ el_ $ text "no results!"
resultsView (Just x) = col (border 3 . pad 10) $ do
                        el_ $ text "results"
                        route (ResultRequested x) id $ "link to share" -- yields "/resultrequested" for Route1 where "/resultrequested/Route1" would be expected
                        row (border 1) $ el_ $ text "…buttons for filtering"
                        text $ case x of
                          Result1 -> "one short result"
                          Result2 -> "a different result"
                          Result3 -> "this is a special result"
                          Result4 -> "THIS IS NUUUMBER FOOOOUUUUR!"
                          Result5 -> "give me high five"
                          Result6 -> "and no. 6"

• route (ResultRequested x) id $ "link to share" yields "/resultrequested" for Route1 where "/resultrequested/Route1" would be expected (for any other like Route2 "resultrequested/Route2" are generated
• "/resultrequested/Route1" still works

[seanhess]

Maybe you can help me out with a design problem here. I wanted the ability for a user to define subroutes, but also a "main" route:

data MyRoute
  = Main
  | One
  | Two
  deriving (Generic, Route)

So the user can visit / and get Main, /one for One, etc. As you've noticed, /main still works.

The route function assumes you want to use this pattern. Take a look at the definition of routePath: it's doing this deliberately https://github.com/seanhess/hyperbole/blob/main/src/Web/Hyperbole/Route.hs#L52. I've found I use this pattern more often than I want to avoid it, and have all the constructors be peers.

Do you have any suggestions? One alternative would be to NOT assume the user wants this and require them to specify defRoute that the user would need to make the presence of a default route explicit:

-- This would work as you expect, with /one, /two, and /three generated
data MyRoute
  = One
  | Two
  | Three
  deriving (Generic, Route)

-- This would work like the library does now
data MyRoute
  = Main
  | One
  | Two
  deriving (Generic)
instance Route MyRoute where
  defRoute = Just Main -- we change this to a maybe to make it optional

Let me know your thoughts!