diff --git a/src-ui.v3/src/Main.hs b/src-ui.v3/src/Main.hs index f03ee69..6d821ce 100644 --- a/src-ui.v3/src/Main.hs +++ b/src-ui.v3/src/Main.hs @@ -119,7 +119,7 @@ bodyElement4 = do app :: forall t m. (SetRoute t FragRoute m, SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace) => FragRoute -- Dynamic t FragRoute -> m () -app dynFrag = do +app fragRoute = do -- top-level PB event evPB0 <- getPostBuild @@ -142,11 +142,11 @@ app dynFrag = do -- pseudo navbar el "nav" $ do text "[ " - routeLink False "#/" (text "HOME") + routeLink False RouteHome (text "HOME") text " | " - routeLink False "#/queue" (text "Build Queue") + routeLink False RouteQueue (text "Build Queue") text " | " - routeLink False "#/packages" (text "Packages") + routeLink False RoutePackages (text "Packages") text " ]" text " (current index-state: " dynText (pkgIdxTsToText <$> dynIdxStLast) @@ -158,7 +158,7 @@ app dynFrag = do _ <- searchBoxWidget dynPackages0 el "hr" blank - _ <- case dynFrag of --dyn $ dynFrag >>= \case + _ <- case fragRoute of RouteHome -> do elAttr "div" (("id" =: "page-home") <> ("class" =: "page")) $ do divClass "leftcol" $ do @@ -244,7 +244,6 @@ app dynFrag = do el "h1" $ text "Queue" el "div" $ do - -- aButton <- el "div" $ button "Refresh Queue" evQRows <- getQueue (leftmost [ticker4 $> (), evPB]) dynQRows <- holdUniqDyn =<< holdDyn mempty evQRows @@ -521,7 +520,7 @@ packagesPageWidget dynPackages dynTags dynPkgTags = do pure $ do el "ol" $ forM_ v' $ \(pn) -> do - el "li" $ routeLink False ("#/package/" <> (pkgNToText pn)) $ do + el "li" $ routeLink False (RoutePackage pn) $ do text ((pkgNToText pn) <> " : ") case Map.lookup pn dpt of Just tags -> forM tags $ \(tag0) -> elAttr "a" (("class" =: "tag-item") <> ("data-tag-name" =: (tagNToText tag0))) $ text (tagNToText tag0) @@ -640,7 +639,7 @@ renderRow pn' hcvs pitrIdxstate wip inQueue ppV pcV t u cs = do elAttr "th" ("style" =: "text-align:left;") (text (verToText pcV)) el "td" $ text (pkgIdxTsToText t) - el "td" $ routeLink False ("#/user/" <> u) (text u) + el "td" $ routeLink False (RouteUser u) (text u) pure (leftmost evsRow1) reportDetailWidget :: (SupportsServantReflex t m, MonadFix m, PostBuild t m, DomBuilder t m, Reflex t, MonadHold t m, Adjustable t m) => Dynamic t (Maybe (PkgN,Ver,CompilerID,PkgIdxTs)) -> m () @@ -832,10 +831,10 @@ searchResultWidget mDyn = el "ul" $ do exactE <- listViewWithKey (matchesExact <$> mDyn) $ \eId _ -> do (e, _) <- element "li" def $ - routeLink False ("#/package/" <> eId) $ el "strong" $ text eId + routeLink False (RoutePackage (PkgN eId)) $ el "strong" $ text eId pure $ domEvent Click e otherE <- listViewWithKey (matchesInfix <$> mDyn) $ \pId txt -> do - (e, _) <- element "li" def $ routeLink False ("#/package/" <> pId) $ do + (e, _) <- element "li" def $ routeLink False (RoutePackage (PkgN pId)) $ do dynText . fmap (^. _1) $ txt el "strong" $ dynText . fmap (^. _2) $ txt dynText . fmap (^. _3) $ txt diff --git a/src-ui.v3/src/Router.hs b/src-ui.v3/src/Router.hs index 9f46186..da6c0ba 100644 --- a/src-ui.v3/src/Router.hs +++ b/src-ui.v3/src/Router.hs @@ -61,6 +61,7 @@ import Reflex.EventWriter.Base import Reflex.Dom.Builder.Class import Language.Javascript.JSaddle (MonadJSM, jsNull) import Reflex.Dom.Core +import Reflex.Dom.Location import qualified GHCJS.DOM as DOM import GHCJS.DOM.Types (SerializedScriptValue (..)) import qualified GHCJS.DOM.Window as Window @@ -156,21 +157,15 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where routeLink :: forall t m a. ( DomBuilder t m, SetRoute t FragRoute m) => Bool -- PreventDefault? - -> Text -- Target route + -> FragRoute -- Target route -> m a -- Child widget -> m a -routeLink True r w = do +routeLink isPrevent route w = do let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m)) - & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault) - & elementConfig_initialAttributes .~ "href" =: r + & elementConfig_initialAttributes .~ "href" =: (fromMaybe "#/" (encodeFrag route)) + & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> mempty {_eventFlags_preventDefault = isPrevent }) (e, a) <- element "a" cfg w - setRoute $ (switchPkgRoute (Just $ decodeFrag r)) <$ domEvent Click e - return a -routeLink False r w = do - let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m)) - & elementConfig_initialAttributes .~ "href" =: r - (e, a) <- element "a" cfg w - setRoute $ (switchPkgRoute (Just $ decodeFrag r)) <$ domEvent Click e + setRoute $ (switchPkgRoute (Just route)) <$ domEvent Click e return a routePkgIdxTs :: forall t m. (PerformEvent t m, TriggerEvent t m, MonadJSM m, MonadJSM (Performable m), PostBuild t m, MonadHold t m, MonadFix m, DomBuilder t m, SetRoute t FragRoute m) @@ -191,7 +186,7 @@ routePkgIdxTs pn setIdx ddIdx = do }) <$> evDD _ <- manageHistory $ HistoryCommand_PushState <$> res - setRoute $ switchPkgRoute <$> evDD + --setRoute $ switchPkgRoute <$> evDD pure () fromRoutePackage :: Maybe FragRoute -> URI -> Maybe URI @@ -213,34 +208,40 @@ runRouteViewT :: forall t m. (MonadHold t m, MonadSample t m, Adjustable t m, T => (FragRoute -> SetRouteT t FragRoute m ()) -> m () runRouteViewT app = mdo + window <- DOM.currentWindowUnchecked + location <- Window.getLocation window + currUri <- getLocationUri location historyState <- manageHistory $ HistoryCommand_PushState <$> setState - let dynLoc = _historyItem_uri <$> historyState route :: Dynamic t FragRoute route = decodeFrag . T.pack . uriFragment <$> dynLoc - setState = fmapMaybe id $ attachWith switchRoutingState ( (,) <$> current historyState <*> current route) changeStateE + setState = fmapMaybe id $ attachWith (switchRoutingState currUri) ( (,) <$> current historyState <*> current route) changeStateE (result, changeStateE) <- runSetRouteT $ strictDynWidget_ app route pure result -switchFrag :: FragRoute -> FragRoute -> Maybe FragRoute -switchFrag newFrag oldFrag + +switchFrag :: FragRoute -> FragRoute -> FragRoute -> Maybe FragRoute +switchFrag cUri newFrag oldFrag | True <- newFrag == oldFrag = Nothing | (RoutePackage _) <- newFrag , (RoutePackage _) <- oldFrag + , (RoutePackage _) <- cUri = Nothing | otherwise = Just newFrag -switchRoutingState :: (HistoryItem, FragRoute) -> Endo FragRoute -> Maybe HistoryStateUpdate -switchRoutingState (currentHS, oldR) chStateE = +switchRoutingState :: URI -> (HistoryItem, FragRoute) -> Endo FragRoute -> Maybe HistoryStateUpdate +switchRoutingState currUri (currentHS, oldR) chStateE = let newRoute = appEndo chStateE oldR + cUri = decodeFrag $ (T.pack . uriFragment) currUri in do newState <- encodeFrag newRoute oldRoute <- encodeFrag oldR - _ <- switchFrag newRoute oldR + _ <- if cUri == newRoute || cUri == oldR then Nothing else Nothing + _ <- switchFrag cUri newRoute oldR newUri <- applyEncoding oldRoute newState (_historyItem_uri currentHS) pure $ HistoryStateUpdate { _historyStateUpdate_state = SerializedScriptValue jsNull