Fixed dyn and cleaning some warning

Author: Andika Demas Riyandi

src-ui.v3/src/Main.hs

@@ -110,7 +110,7 @@ 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
-  _ <- runRouteViewT' app
+  _ <- runRouteViewT app
 
   --(result, changeStateE) <- runSetRouteT $ app RouteHome 
   pure ()

src-ui.v3/src/Router.hs

@@ -33,7 +33,6 @@ module Router
   , routeLink
   , routePkgIdxTs
   , runRouteViewT
-  , runRouteViewT'
   , FragRoute(..), decodeFrag, encodeFrag
   ) where
 
@@ -63,13 +62,8 @@ import           Reflex.Dom.Builder.Class
 import           Language.Javascript.JSaddle (MonadJSM, jsNull)
 import           Reflex.Dom.Core
 import qualified GHCJS.DOM as DOM
-import qualified GHCJS.DOM.WindowEventHandlers as DOM
-import qualified GHCJS.DOM.EventM as DOM
-import           GHCJS.DOM.Types (History, Window, SerializedScriptValue (..), liftJSM, fromJSVal, toJSVal)
+import           GHCJS.DOM.Types (SerializedScriptValue (..))
 import qualified GHCJS.DOM.Window as Window
-import qualified GHCJS.DOM.History as History
-import qualified GHCJS.DOM.Location as Location
-import qualified GHCJS.DOM.PopStateEvent as PopStateEvent
 import           Network.URI
 import           Data.Maybe (Maybe(..), fromMaybe)
 
@@ -179,27 +173,45 @@ routeLink False r w = do
   setRoute $ (switchPkgRoute (Just $ decodeFrag r)) <$ domEvent Click e 
   return a
 
-routePkgIdxTs :: forall t m. (PostBuild t m, MonadHold t m, MonadFix m, DomBuilder t m, SetRoute t FragRoute m) 
+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) 
               => PkgN
               -> Dynamic t (Set PkgIdxTs)
               -> Dynamic t PkgIdxTs
               -> m ()
 routePkgIdxTs pn setIdx ddIdx = do
   let evDD = updated $ ffor2 setIdx ddIdx (\sId dVal -> createRoutePackage pn sId dVal)
+  window <- DOM.currentWindowUnchecked
+  location <- Window.getLocation window
+  uri <- getLocationUri location
+  let
+    res = (\x -> HistoryStateUpdate
+            { _historyStateUpdate_state = SerializedScriptValue jsNull
+            , _historyStateUpdate_title = ""
+            , _historyStateUpdate_uri   = fromRoutePackage x uri
+            }) <$> evDD
+  _ <- manageHistory $ HistoryCommand_PushState <$> res
+  
   setRoute $ switchPkgRoute <$> evDD
   pure ()
 
+fromRoutePackage :: Maybe FragRoute -> URI -> Maybe URI
+fromRoutePackage frag oldUri
+  | Just fragRoute <- frag
+  , (RoutePackage txt) <- fragRoute
+  = Just $ oldUri { uriFragment = T.unpack $  (pkgNToText txt)}
+  | otherwise = Nothing
+
 createRoutePackage :: PkgN -> Set PkgIdxTs -> PkgIdxTs -> Maybe FragRoute
 createRoutePackage _ _ (PkgIdxTs 0) = Nothing
 createRoutePackage (PkgN pn) setIdx pkgIdx
   | Just maxIdx <- Set.lookupMax setIdx
   , True     <- maxIdx /= pkgIdx
-  = Just $ RoutePackage (PkgN $ T.append pn (cons '@' $ idxTsToText pkgIdx))
-  | otherwise = Just $ RoutePackage (PkgN pn)
+  = Just $ RoutePackage (PkgN $ "#/package/" <> pn <> "@" <> (idxTsToText pkgIdx))
+  | otherwise = Just $ RoutePackage (PkgN $ "#/package/" <> pn)
 
-runRouteViewT  :: forall t m. (Adjustable t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, MonadJSM m, MonadJSM (Performable m), MonadFix m)
+runRouteViewT  :: forall t m. (MonadHold t m, MonadSample t m, Adjustable t m, TriggerEvent t m, PerformEvent t m, MonadJSM m, MonadJSM (Performable m), MonadFix m)
                => (FragRoute -> SetRouteT t FragRoute m ())
-               -> m () --(Dynamic t (Maybe Text))
+               -> m ()
 runRouteViewT app = mdo
   historyState <- manageHistory $ HistoryCommand_PushState <$> setState
 
@@ -209,25 +221,7 @@ runRouteViewT app = mdo
     route :: Dynamic t FragRoute
     route = decodeFrag . T.pack . uriFragment <$> dynLoc
 
-    setState = attachWithMaybe switchRoutingState ( (,) <$> current historyState <*> current route) changeStateE
-  (result, changeStateE) <- runSetRouteT $ strictDynWidget_ app route
-  pure result
-
-runRouteViewT'  :: forall t m. (MonadJSM m, Adjustable t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, MonadFix m, MonadJSM (Performable m))
-               => (FragRoute -> SetRouteT t FragRoute m ())
-               -> m () --(Dynamic t (Maybe Text))
-runRouteViewT' app = mdo
-  window <- DOM.currentWindowUnchecked
-  history <- Window.getHistory window
-  location <- Window.getLocation window
-  oldUri <- (decodeFrag . T.pack . uriFragment) <$> getLocationUri location
-  backState <- wrapDomEvent window (`DOM.on` DOM.popState) $ do
-    e <- DOM.event
-    jV <- PopStateEvent.getState e
-    oUri <- liftJSM $ fromJSVal jV
-    pure $ decodeFrag $ fromMaybe (T.pack "") oUri
-  setState <- performEvent $ attachWith (switchRoutingState' history) (current route) changeStateE
-  route <- foldDynMaybe switchFrag oldUri $ setState
+    setState = fmapMaybe id $ attachWith switchRoutingState ( (,) <$> current historyState <*> current route) changeStateE
   (result, changeStateE) <- runSetRouteT $ strictDynWidget_ app route
   pure result
 
@@ -237,43 +231,22 @@ switchFrag newFrag oldFrag
   = Nothing
   | (RoutePackage _) <- newFrag
   , (RoutePackage _) <- oldFrag
-  = Just newFrag
+  = Nothing
   | otherwise = Just newFrag
 
-{-backRoutingState :: (MonadJSM m) => History -> m FragRoute
-backRoutingState hs = wrapDomEvent window (`DOM.on` DOM.popState) $ do
-  e <- DOM.event
-  jV <- PopStateEvent.getState e
-  oUri <- liftJSM $ fromJSVal jV
-  pure $ decodeFrag $ fromMaybe (T.pack "") oUri
--}
-switchRoutingState' :: (MonadJSM m) => History -> FragRoute -> Endo FragRoute -> m FragRoute
-switchRoutingState' hs oldR chStateE = do
-  let newRoute' = appEndo chStateE oldR
-      newRoute  = encodeFrag newRoute'
-      oldRoute  = fromMaybe (T.pack "") $ encodeFrag oldR
-      histRoute = fromMaybe (T.pack "") $ newRoute
-
-  newState <- liftJSM $ toJSVal histRoute
-  History.pushState hs 
-                    (SerializedScriptValue newState)
-                    histRoute
-                    (applyEncoding' oldRoute newRoute)
-  pure newRoute'
-
 switchRoutingState :: (HistoryItem, FragRoute) -> Endo FragRoute -> Maybe HistoryStateUpdate
-switchRoutingState (currentHS, oldR) chStateE = -- chState :: Endo (FragRoute -> FragRoute)
-  let newR     = appEndo chStateE oldR
-      switchF  = switchFrag newR oldR
-      oldRoute = fromMaybe (T.pack "") $ encodeFrag oldR
-      
-  in case switchF of
-    Nothing -> Nothing
-    Just nR -> Just $ HistoryStateUpdate
-                       { _historyStateUpdate_state = SerializedScriptValue jsNull
-                       , _historyStateUpdate_title = ""
-                       , _historyStateUpdate_uri   = applyEncoding oldRoute nR (_historyItem_uri currentHS)
-                       }
+switchRoutingState (currentHS, oldR) chStateE =
+  let newRoute = appEndo chStateE oldR
+  in do
+      newState <- encodeFrag newRoute
+      oldRoute <- encodeFrag oldR
+      _ <- switchFrag newRoute oldR
+      newUri <- applyEncoding oldRoute newState (_historyItem_uri currentHS)
+      pure $ HistoryStateUpdate
+            { _historyStateUpdate_state = SerializedScriptValue jsNull
+            , _historyStateUpdate_title = ""
+            , _historyStateUpdate_uri   = Just newUri
+            }
 
 switchPkgRoute :: Maybe FragRoute -> FragRoute -> FragRoute
 switchPkgRoute newFrag oldFrag = fromMaybe oldFrag newFrag
@@ -286,16 +259,9 @@ encodeFrag (RoutePackage (PkgN pkg)) = Just $ "#/package/" <> pkg
 encodeFrag (RouteUser usr) = Just $ "#/user/" <> usr
 encodeFrag (RouteUnknown _) = Nothing
 
-applyEncoding' :: Text -> Maybe Text -> Maybe Text
-applyEncoding' _ Nothing = Nothing
-applyEncoding' oldR (Just newR)
-  | oldR /= newR = Just $ newR
-  | otherwise    = Nothing
-
-applyEncoding :: Text -> FragRoute -> URI -> Maybe URI
-applyEncoding oldR r u 
-  | Just newR <- encodeFrag r
-  , oldR /= newR = Just $ u { uriFragment = T.unpack newR }
+applyEncoding :: Text -> Text -> URI -> Maybe URI
+applyEncoding oldR newR u 
+  | oldR /= newR = Just $ u { uriFragment = T.unpack newR }
   | otherwise    = Nothing
 
 decodeFrag :: T.Text -> FragRoute
@@ -318,7 +284,10 @@ decodeFrag frag = case frag of
 
       | otherwise -> RouteUnknown frag
 
-strictDynWidget_ :: forall t m. ( MonadSample t m, MonadHold t m, Adjustable t m) => (FragRoute -> m ()) -> Dynamic t FragRoute -> m ()
+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