@@ -12,6 +12,7 @@ module Reflex.Dom.Location
1212 , getLocationProtocol
1313 , getLocationUrl
1414 , manageHistory
15+ , manageHistory'
1516 , HistoryCommand (..)
1617 , HistoryStateUpdate (..)
1718 , HistoryItem (..)
@@ -23,8 +24,11 @@ import Reflex.Dom.Builder.Immediate (wrapDomEvent)
2324
2425import Control.Lens ((^.))
2526import Control.Monad ((>=>))
27+import Control.Monad.Fix (MonadFix)
28+import Data.Align (align)
2629import Data.Monoid
2730import Data.Text (Text)
31+import Data.These (These(..))
2832import qualified GHCJS.DOM as DOM
2933import qualified GHCJS.DOM.EventM as DOM
3034import qualified GHCJS.DOM.Location as Location
@@ -159,3 +163,38 @@ manageHistory runCmd = do
159163 <*> getLocationUri location
160164 holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
161165--TODO: Handle title setting better
166+
167+manageHistory'
168+ :: (MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m))
169+ => Event t ()
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
182+ e <- DOM.event
183+ HistoryItem
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
188+ This change
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