@@ -12,6 +12,7 @@ module Reflex.Dom.Location
12 , getLocationProtocol
12 , getLocationProtocol
13 , getLocationUrl
13 , getLocationUrl
14 , manageHistory
14 , manageHistory
15 , HistoryCommand (..)
16 , HistoryCommand (..)
16 , HistoryStateUpdate (..)
17 , HistoryStateUpdate (..)
17 , HistoryItem (..)
18 , HistoryItem (..)
@@ -23,8 +24,11 @@ import Reflex.Dom.Builder.Immediate (wrapDomEvent)
24import Control.Lens ((^.))
25import Control.Lens ((^.))
25import Control.Monad ((>=>))
26import Control.Monad ((>=>))
27+import Control.Monad.Fix (MonadFix)
28+import Data.Align (align)
26import Data.Monoid
29import Data.Monoid
27import Data.Text (Text)
30import Data.Text (Text)
31+import Data.These (These(..))
28import qualified GHCJS.DOM as DOM
32import qualified GHCJS.DOM as DOM
29import qualified GHCJS.DOM.EventM as DOM
33import qualified GHCJS.DOM.EventM as DOM
30import qualified GHCJS.DOM.Location as Location
34import qualified GHCJS.DOM.Location as Location
@@ -159,3 +163,38 @@ manageHistory runCmd = do
159 <*> getLocationUri location
163 <*> getLocationUri location
160 holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
164 holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
161--TODO: Handle title setting better
165--TODO: Handle title setting better
168+ :: (MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m))
170+ -- ^ Don't do anything until this event has fired
171+ -> Event t HistoryCommand
172+ -> m (Dynamic t HistoryItem)
173+manageHistory' switchover runCmd = do
174+ window <- DOM.currentWindowUnchecked
175+ location <- Window.getLocation window
176+ history <- Window.getHistory window
177+ let getCurrentHistoryItem = HistoryItem
178+ <$> History.getState history
179+ <*> getLocationUri location
180+ item0 <- liftJSM getCurrentHistoryItem
181+ itemSetExternal' <- wrapDomEvent window (`DOM.on` DOM.popState) $ do
184+ <$> (SerializedScriptValue <$> PopStateEvent.getState e)
185+ <*> getLocationUri location
186+ let f :: (Bool, Maybe a) -> These a () -> (Maybe (Bool, Maybe a), Maybe a)
187+ f (switched, acc) = \case
189+ | switched -> (Nothing, Just change)
190+ | otherwise -> (Just (switched, Just change), Nothing)
191+ That () -> (Just (True, Nothing), acc)
192+ These change () -> (Just (True, Nothing), Just change)
193+ -- Accumulate the events before switchover
194+ (_, cmd') <- mapAccumMaybeB f (False, Nothing) $ align (leftmost [Left <$> runCmd, Right <$> itemSetExternal']) switchover
195+ let (itemSetInternal', itemSetExternal) = fanEither cmd'
196+ itemSetInternal <- performEvent $ ffor itemSetInternal' $ \cmd -> liftJSM $ do
197+ runHistoryCommand history cmd
198+ getCurrentHistoryItem
199+ holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
200+--TODO: Handle title setting better