Reflex routing

Router.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where

import Control.Monad (void)
import Data.Maybe (fromMaybe)

import Data.Text (Text)

import Reflex.Dom

import Reflex.Dom.Routing.Nested
import Reflex.Dom.Routing.Writer

main :: IO ()
main = mainWidget $ el "div" $ do
  runRouteWithPathInFragment $ fmap snd $ runRouteWriterT $
    withRoute $ \route -> case fromMaybe "" route of
      "" -> do
        relButton "A" "a"
        relButton "B" "b"
        pure never
      "a" -> numberLayer
      "b" -> numberLayer
      _ -> do
        tellRedirectLocally []
        pure never

numberLayer :: (MonadWidget t m, HasRoute t Text m, RouteWriter t Text m)
            => m (Event t ())
numberLayer =
  withRoute $ \route -> case fromMaybe "" route of
    "" -> do
      relButton "1" "1"
      relButton "2" "2"
      backButton "Back"
    "1" ->
      backButton "Back"
    "2" ->
      backButton "Back"
    _ ->
      tellRedirectLocally []

relButton :: (MonadWidget t m, HasRoute t Text m, RouteWriter t Text m)
          => Text
          -> Text
          -> m ()
relButton label ref = do
  e <- button label
  tellRouteRelativeAs [ref] e

backButton :: (MonadWidget t m, HasRoute t Text m, RouteWriter t Text m)
          => Text
          -> m ()
backButton label = do
  e <- button label
  parents <- parentRouteSegments
  tellRoute $ init <$> current parents <@ e