Skip to content

Instantly share code, notes, and snippets.

@spinus
Created July 1, 2017 18:29
Show Gist options
  • Save spinus/26dccbbc2f879cb2650cb98da57abd25 to your computer and use it in GitHub Desktop.
Save spinus/26dccbbc2f879cb2650cb98da57abd25 to your computer and use it in GitHub Desktop.
gist1
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_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 ()
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
@luigy
Copy link

luigy commented Jul 1, 2017

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 ()

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment