gist1

Controller.hs

data Controller a b t m = Controller {
  _session :: R.Dynamic t D.Session,
  _router  :: D.Router a b t m
}

controller :: R.Reflex t => R.Dynamic t D.Session -> D.Router a b t m -> Controller a b t m
controller session router =
  Controller {
    _session = session,
    _router = router
  }

Main.hs

main_view :: (R.MonadWidget t m) => m ()
main_view = do
      -- initizlize first URL change event on application start

      ev <- R.getPostBuild
      -- initialize controller with default session and function to change URL state
      --isv :: R.Event t D.Session <- D.is_session_valid ev
      --session <- R.holdDyn D.NoSession (isv)
      --let c = D.controller session

      router <- D.instantiate_router [D.LoginPage] D.LoginPage

      x <- R.button "Change view"
      y <- R.button "Change page"

      _ <- R.performEvent $ (\e -> liftIO ((D.change_view router) D.LoginPage)) <$> x
      _ <- R.performEvent $ (\e -> liftIO ((D.change_page router) D.LoginPage)) <$> y

      session <- R.holdDyn NoSession (NoSession <$ ev)
      let controller = D.Controller { D._session = session, D._router = router }
      R.widgetHold (R.text "bla") ( D.render_view <$> (R.traceEvent "main: view changed" (D.view_changed router)))
      return ()

Router.hs

class Page a where
  title :: a -> Text
  to_path :: a -> Text
  from_path :: Text -> Maybe a

class R.MonadWidget t m => View t m a where
  render_view :: a -> m ()

--class R.MonadWidget t m => Router t a m where
--  --set_url :: a -> Text -> IO ()
--  set_view :: (R.MonadWidget t m, View t m b) => a -> b -> m (IO ())
--  --set_page :: Page b => a -> b -> IO ()



data LandingPage = LandingPage
data LoginPage = LoginPage
data LoanPage = LoanPage { loan_id :: !Int }

instance Page LandingPage where
  title a = "Dealomat"
  to_path a = "/"

instance Page LoginPage where
  title a = "Logowanie"
  to_path a = "/logowanie"

instance Show LoginPage where
  show a = "LoginPage"

instance R.MonadWidget t m => View t m LoginPage where
  render_view a = R.text "Login Page :-)"

instance Page LoanPage where
  title a = "Pożyczka"
  to_path a = T.concat ["/pozyczka/"::Text, convertString (show (loan_id a))]

push_url_state :: R.MonadWidget t m => R.Event t Text -> Bool -> m (R.Event t Text)
push_url_state ev reload = do
  R.performEvent $ R.ffor ev $ \url -> do
      liftIO $ putStrLn $ convertString $ T.concat ["main: pushing URL state: "::Text, url]
      liftIO $ do
        Just w <- JS.currentWindow
        h <- JS.getHistory w
        JS.pushState h (0::Double) (""::Text) (Just (url::Text))
        case reload of
          True -> do
            JS.forward h
            JS.go h (Just (0::Int))
          False -> return ()
  return ev


data (Page a, View t m b, R.MonadWidget t m) => Router a b t m = Router {
  change_page  :: a -> IO (),
  change_view  :: b -> IO (),
  page_changed :: R.Event t a,
  view_changed :: R.Event t b
}


instantiate_router :: (R.MonadWidget t m, Show a, Page a, View t m a) => [a] -> a -> m (Router a a t m)
instantiate_router pages start_page = do
      -- initizlize first URL change event on application start
      ev <- R.getPostBuild
      h <- liftIO $ get_url_path
      (___page_changed_event, change_page) :: (R.Event t a, a -> IO ()) <- R.newTriggerEvent
      let __page_changed_event = (R.traceEvent "router: Page change triggered: " ___page_changed_event)
      _page_changed_event <- push_url_state (to_path <$> __page_changed_event) False
      let page_changed_event = (R.traceEvent "router: Page has changed to: "
              (R.leftmost [
                start_page <$ ev,  -- page is set on start
                __page_changed_event -- or can be changed manually
                ]))

      let start_view = start_page
      (__view_changed_event, change_view) :: (R.Event t a, a -> IO ()) <- R.newTriggerEvent
      let _view_changed_event = (R.traceEvent "router: View change triggered: " __view_changed_event)
      let view_changed_event = (R.traceEvent "router: View has changed to: "
              (R.leftmost [
                _view_changed_event, -- view can change by triggering manual view change
                __page_changed_event -- or by changing page
              ]))
      return $ Router change_page change_view page_changed_event view_changed_event

Updated example to avoid having to pass down functions to perform route changes in favor of collecting route events using EventWriter and performing the actual route changes in one location.

main_view :: (R.MonadWidget t m) => m ()
main_view = do
      -- initizlize first URL change event on application start

      ev <- R.getPostBuild
      -- initialize controller with default session and function to change URL state
      --isv :: R.Event t D.Session <- D.is_session_valid ev
      --session <- R.holdDyn D.NoSession (isv)
      --let c = D.controller session

      router <- D.instantiate_router [D.LoginPage] D.LoginPage

      (_, routeChanges) <- runEventWriterT $ do
        x <- R.button "Change view"
        y <- R.button "Change page"

        tellEvent $ Left D.LoginPage <$ x
        tellEvent $ Right D.LoginPage <$ y

        session <- R.holdDyn NoSession (NoSession <$ ev)
        let controller = D.Controller { D._session = session, D._router = router }
        R.widgetHold (R.text "bla") ( D.render_view <$> (R.traceEvent "main: view changed" (D.view_changed router)))

      R.performEvent_ $ ffor routeChanges $ \case
        Left r -> D.change_view router r
        Right r -> D.change_page router r

      return ()