Deduplicate and simplified routeLink and small code clean up

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

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