Initial Fix

Author: Andika Demas Riyandi

src-ui.v3/matrix-ui.cabal

@@ -17,6 +17,7 @@ executable matrix-ui
   main-is: Main.hs
   other-modules: API
                , PkgId
+               , Router
 
   mixins: base hiding (Prelude)
 

src-ui.v3/src/Main.hs

@@ -49,6 +49,8 @@ import qualified Data.Vector               as V
 import qualified Data.Version              as Ver
 import           GHC.Generics              (Rep)
 import qualified GHCJS.DOM.Types           as DOM
+import qualified GHCJS.DOM.Window as Window
+import qualified GHCJS.DOM as DOM
 import           Language.Javascript.JSaddle (jsNull)
 import           Network.URI
 --import           Reflex.Dom
@@ -107,15 +109,13 @@ utc2unix x = ceiling (realToFrac (utcTimeToPOSIXSeconds x) :: Double)
 
 bodyElement4 :: forall t m . (SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace) => m ()
 bodyElement4 = do
-  --dynLoc <- browserHistoryWith getLocationUri
-  --let dynFrag = decodeFrag . T.pack . uriFragment <$> dynLoc
   _ <- runRouteViewT app
+
+  --(result, changeStateE) <- runSetRouteT $ app RouteHome 
   pure ()
-  -- ticker1 <- tickLossy 1 =<< liftIO getCurrentTime
---    ticker1cnt <- count ticker1
 
 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) 
-    => Dynamic t FragRoute
+    => FragRoute -- Dynamic t FragRoute
     -> m ()
 app dynFrag = do
   -- top-level PB event
@@ -156,8 +156,8 @@ app dynFrag = do
   _ <- searchBoxWidget dynPackages0
   el "hr" blank
 
-  _ <- dyn $ dynFrag >>= \case
-    RouteHome -> pure $ do
+  _ <- case dynFrag of --dyn $ dynFrag >>= \case
+    RouteHome -> do
       elAttr "div" (("id" =: "page-home") <> ("class" =: "page")) $ do
         divClass "leftcol" $ do
           elAttr "h2" ("class" =: "main-header") $ text "Welcome"
@@ -205,7 +205,7 @@ app dynFrag = do
                 text "Cookbook for common build failures"
       pure ()
 
-    RouteQueue -> pure $ do
+    RouteQueue -> do
       evPB <- getPostBuild
 
       let dynUnixTime = utc2unix <$> dynUTCTime
@@ -320,7 +320,7 @@ app dynFrag = do
             pure ()
         pure ()
 
-    RoutePackages -> pure $ do
+    RoutePackages -> do
         el "h1" $ text "Packages"
         evPB <- getPostBuild
         evTags<- getTags (constDyn $ QParamSome False) evPB
@@ -330,7 +330,7 @@ app dynFrag = do
         let dynPkgTags = pkgTagList <$> dynTagPkgs
         packagesPageWidget dynPackages0 dynTags dynPkgTags
 
-    RoutePackage (pn, idxSt) -> pure $ do
+    RoutePackage (pn, idxSt) -> do
 
         el "h2" $ text (pkgNToText pn)
         el "p" $ el "em" $ elAttr "a" ("href" =: ("https://hackage.haskell.org/package/" <> pkgNToText pn)) $
@@ -380,8 +380,7 @@ app dynFrag = do
         ddReports <- el "p" $ do
           evQButton <- button "Queue a build"
           text " for the index-state "
-          uniqReport <- holdUniqDyn dynReports
-          tmp <- routePkgIdxTs pn (PkgIdxTs 0) uniqReport xs ddCfg
+          tmp <- routePkgIdxTs pn (PkgIdxTs 0) dynReports xs ddCfg
           text " shown below"
 
           _ <- putQueue (constDyn $ Right pn) (Right <$> _dropdown_value tmp) (constDyn $ Right (QEntryUpd (-1))) evQButton
@@ -434,7 +433,7 @@ app dynFrag = do
 
         pure ()
 
-    RouteUser u -> pure $ do
+    RouteUser u -> do
         el "h1" (text u)
 
         evPB <- getPostBuild
@@ -447,7 +446,7 @@ app dynFrag = do
 
         pure ()
 
-    RouteUnknown frag -> pure $ do
+    RouteUnknown frag -> do
         el "p" $ text ("No handler found for " <> T.pack (show frag))
         pure ()
 

src-ui.v3/src/Router.hs

@@ -63,6 +63,8 @@ import           Reflex.Dom.Builder.Class
 import           Language.Javascript.JSaddle
 import           Reflex.Dom.Core
 import qualified GHCJS.DOM.Types as DOM
+import qualified GHCJS.DOM.Window as Window
+import qualified GHCJS.DOM as DOM
 import           Network.URI
 import           Data.Maybe (Maybe(..), fromMaybe)
 
@@ -187,41 +189,47 @@ routePkgIdxTs pn k0 setIdx opt ddConf = do
   pure dd
 
 createRoutePackage :: PkgN -> Set PkgIdxTs -> PkgIdxTs -> Maybe FragRoute
-createRoutePackage pn _ (PkgIdxTs 0) = Nothing
+createRoutePackage _ _ (PkgIdxTs 0) = Nothing
 createRoutePackage pn setIdx pkgIdx
   | Just maxIdx <- Set.lookupMax setIdx
   , True     <- maxIdx /= pkgIdx
   = Just $ RoutePackage (pn, Just pkgIdx)
   | otherwise = Just $ RoutePackage (pn, Nothing)
 
-runRouteViewT  :: forall t m a. (TriggerEvent t m, PerformEvent t m, MonadHold t m, MonadJSM m, MonadJSM (Performable m), MonadFix m)
-               => (Dynamic t FragRoute -> SetRouteT t FragRoute m a)
-               -> m a
+switchHistoryItem :: HistoryCommand -> HistoryItem -> HistoryItem
+switchHistoryItem hC hI
+  | (HistoryCommand_PushState su) <- hC
+  , (Just uri) <- _historyStateUpdate_uri su
+  = hI { _historyItem_uri = uri }
+  | otherwise = hI 
+
+runRouteViewT  :: forall t m. (Adjustable t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, MonadJSM m, MonadJSM (Performable m), MonadFix m)
+               => (FragRoute -> SetRouteT t FragRoute m ())
+               -> m (Dynamic t (Maybe Text))
 runRouteViewT app = mdo
   historyState <- manageHistory $ HistoryCommand_PushState <$> setState
-  --dynLoc <- browserHistoryWith getLocationUri
-  (result, changeStateE) <- runSetRouteT $ app route -- changeStateE :: Event t (Endo (Fragroute -> FragRoute)
+
   let 
     dynLoc = _historyItem_uri <$> historyState
 
     route :: Dynamic t FragRoute
     route = decodeFrag . T.pack . uriFragment <$> dynLoc
 
-    f  (currentHistoryState, oldR) chStateE = -- chState :: Endo (FragRoute -> FragRoute)
-      let newRoute = encodeFrag $ appEndo chStateE oldR
-          --oldRoute = case encodeFrag oldR of
-          --             (Just a) -> a
-          --             Nothing  -> T.empty
-      in do
-        oldRoute <- encodeFrag oldR
-        newUri   <- applyEncoding oldRoute newRoute (_historyItem_uri currentHistoryState)
-        pure $ HistoryStateUpdate
-               { _historyStateUpdate_state = DOM.SerializedScriptValue jsNull
-               , _historyStateUpdate_title = ""
-               , _historyStateUpdate_uri   = Just newUri
-               }
-    setState = fmapMaybe id $ attachWith f ( (,) <$> current historyState <*> current route) changeStateE
-  pure result
+    setState = fmapMaybe id $ attachWith switchRoutingState ( (,) <$> current historyState <*> current route) changeStateE
+  (result, changeStateE) <- runSetRouteT $ strictDynWidget_ app route
+  pure (encodeFrag <$> route)
+
+switchRoutingState :: (HistoryItem, FragRoute) -> Endo FragRoute -> Maybe HistoryStateUpdate
+switchRoutingState (currentHS, oldR) chStateE = -- chState :: Endo (FragRoute -> FragRoute)
+  let newRoute = encodeFrag $ appEndo chStateE oldR
+  in do
+      oldRoute <- encodeFrag oldR
+      newUri   <- applyEncoding oldRoute newRoute (_historyItem_uri currentHS)
+      pure $ HistoryStateUpdate
+             { _historyStateUpdate_state = DOM.SerializedScriptValue jsNull
+             , _historyStateUpdate_title = ""
+             , _historyStateUpdate_uri   = Just newUri
+             }
 
 switchPkgRoute :: Maybe FragRoute -> FragRoute -> FragRoute
 switchPkgRoute newFrag oldFrag = fromMaybe oldFrag newFrag
@@ -261,4 +269,10 @@ decodeFrag frag = case frag of
       , T.all (\c -> C.isAsciiLower c || C.isAsciiUpper c || C.isDigit c || c == '_') sfx
         -> RouteUser sfx
 
-      | otherwise -> RouteUnknown frag
+      | otherwise -> RouteUnknown frag
+
+strictDynWidget_ :: forall t m. ( MonadSample t m, MonadHold t m, Adjustable t m) => (FragRoute -> m ()) -> Dynamic t FragRoute -> m ()
+strictDynWidget_ f r = do
+  r0 <- sample $ current r
+  (_, _) <- runWithReplace (f r0) $ f <$> updated r
+  pure ()