{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Reflex.Dom.Location
  ( browserHistoryWith
  , getLocationAfterHost
  , getLocationFragment
  , getLocationHost
  , getLocationPath
  , getLocationProtocol
  , getLocationUrl
  , manageHistory
  , manageHistory'
  , HistoryCommand (..)
  , HistoryStateUpdate (..)
  , HistoryItem (..)
  , getLocationUri
  ) where

import Reflex
import Reflex.Dom.Builder.Immediate (wrapDomEvent)

import Control.Lens ((^.))
import Control.Monad ((>=>))
import Control.Monad.Fix (MonadFix)
import Data.Align (align)
import Data.Monoid
import Data.Text (Text)
import Data.These (These(..))
import qualified GHCJS.DOM as DOM
import qualified GHCJS.DOM.EventM as DOM
import qualified GHCJS.DOM.Location as Location
import qualified GHCJS.DOM.History as History
import qualified GHCJS.DOM.PopStateEvent as PopStateEvent
import GHCJS.DOM.Types (Location, History, SerializedScriptValue (..), liftJSM)
import qualified GHCJS.DOM.Types as DOM
import qualified GHCJS.DOM.Window as Window
import qualified GHCJS.DOM.WindowEventHandlers as DOM
import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, ToJSVal (..), FromJSVal (..))
import Network.URI

withLocation :: (MonadJSM m) => (Location -> m a) -> m a
withLocation :: (Location -> m a) -> m a
withLocation f :: Location -> m a
f = m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked m Window -> (Window -> m Location) -> m Location
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Window -> m Location
forall (m :: * -> *). MonadDOM m => Window -> m Location
Window.getLocation m Location -> (Location -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Location -> m a
f

-- | Returns the full URI-decoded URL of the current window location.
getLocationUrl :: (MonadJSM m) => m Text
getLocationUrl :: m Text
getLocationUrl = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation (Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHref (Location -> m Text) -> (Text -> m Text) -> Location -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Text
forall (m :: * -> *). MonadJSM m => Text -> m Text
decodeURIText)

-- | Returns the host of the current window location
getLocationHost :: (MonadJSM m) => m Text
getLocationHost :: m Text
getLocationHost = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHost

-- | Returns the protocol/scheme (e.g. @http:@ or @https:@) of the current window location
getLocationProtocol :: (MonadJSM m) => m Text
getLocationProtocol :: m Text
getLocationProtocol = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getProtocol

-- | Returns the URI-decoded location after the host and port; i.e. returns the path, query, and fragment of the location.
getLocationAfterHost :: (MonadJSM m) => m Text
getLocationAfterHost :: m Text
getLocationAfterHost = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation ((Location -> m Text) -> m Text) -> (Location -> m Text) -> m Text
forall a b. (a -> b) -> a -> b
$ \loc :: Location
loc -> do
  Text
pathname <- Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPathname Location
loc
  Text
search <- Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getSearch Location
loc
  Text
hash <- Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHash Location
loc
  Text -> m Text
forall (m :: * -> *) a b.
(MonadJSM m, ToJSString a, FromJSString b) =>
a -> m b
decodeURI ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
pathname, Text
search, Text
hash] :: Text)

-- | Returns the URI-decoded path of the current window location.
getLocationPath :: (MonadJSM m) => m Text
getLocationPath :: m Text
getLocationPath = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation (Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPathname (Location -> m Text) -> (Text -> m Text) -> Location -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Text
forall (m :: * -> *). MonadJSM m => Text -> m Text
decodeURIText)

-- | Returns the URI-decoded fragment/hash of the current window location.
getLocationFragment :: (MonadJSM m) => m Text
getLocationFragment :: m Text
getLocationFragment = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation (Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHash (Location -> m Text) -> (Text -> m Text) -> Location -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Text
forall (m :: * -> *). MonadJSM m => Text -> m Text
decodeURIText)


-- | Decodes a URI with JavaScript's @decodeURI@ function.
--
-- FIXME: @decodeURI@ will throw when URI is malformed
decodeURI :: (MonadJSM m, ToJSString a, FromJSString b) => a -> m b
decodeURI :: a -> m b
decodeURI input :: a
input = do
  Window
window <-  m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  JSVal
window' <- JSM JSVal -> m JSVal
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
DOM.liftJSM (JSM JSVal -> m JSVal) -> JSM JSVal -> m JSVal
forall a b. (a -> b) -> a -> b
$ Window -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Window
window
  JSM b -> m b
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
DOM.liftJSM (JSM b -> m b) -> JSM b -> m b
forall a b. (a -> b) -> a -> b
$ JSVal
window' JSVal -> Getting (JSM JSVal) JSVal (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. Text -> a -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 ("decodeURI"::Text) a
input JSM JSVal -> (JSVal -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSVal -> JSM b
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked

decodeURIText :: (MonadJSM m) => Text -> m Text
decodeURIText :: Text -> m Text
decodeURIText = Text -> m Text
forall (m :: * -> *) a b.
(MonadJSM m, ToJSString a, FromJSString b) =>
a -> m b
decodeURI

-- | Builds a Dynamic carrying the current window location.
browserHistoryWith :: (MonadJSM m, TriggerEvent t m, MonadHold t m)
                   => (forall jsm. MonadJSM jsm => Location -> jsm a)
                   -- ^ A function to encode the window location in a more useful form (e.g. @getLocationAfterHost@).
                   -> m (Dynamic t a)
browserHistoryWith :: (forall (jsm :: * -> *). MonadJSM jsm => Location -> jsm a)
-> m (Dynamic t a)
browserHistoryWith f :: forall (jsm :: * -> *). MonadJSM jsm => Location -> jsm a
f = do
  Window
window <- m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  Location
location <- Window -> m Location
forall (m :: * -> *). MonadDOM m => Window -> m Location
Window.getLocation Window
window
  a
loc0 <- Location -> m a
forall (jsm :: * -> *). MonadJSM jsm => Location -> jsm a
f Location
location
  Event t a
locEv <- Window
-> (Window -> EventM Window PopStateEvent () -> JSM (JSM ()))
-> EventM Window PopStateEvent a
-> m (Event t a)
forall t (m :: * -> *) e event a.
(TriggerEvent t m, MonadJSM m) =>
e
-> (e -> EventM e event () -> JSM (JSM ()))
-> EventM e event a
-> m (Event t a)
wrapDomEvent Window
window (Window
-> EventName Window PopStateEvent
-> EventM Window PopStateEvent ()
-> JSM (JSM ())
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> EventM t e () -> JSM (JSM ())
`DOM.on` EventName Window PopStateEvent
forall self.
(IsWindowEventHandlers self, IsEventTarget self) =>
EventName self PopStateEvent
DOM.popState) (EventM Window PopStateEvent a -> m (Event t a))
-> EventM Window PopStateEvent a -> m (Event t a)
forall a b. (a -> b) -> a -> b
$ Location -> EventM Window PopStateEvent a
forall (jsm :: * -> *). MonadJSM jsm => Location -> jsm a
f Location
location
  a -> Event t a -> m (Dynamic t a)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn a
loc0 Event t a
locEv

--TODO: Pending https://github.com/haskell/network-uri/issues/39, ensure that
--we're handling escaping of URIs correctly
data HistoryItem = HistoryItem
  { HistoryItem -> SerializedScriptValue
_historyItem_state :: SerializedScriptValue
  , HistoryItem -> URI
_historyItem_uri :: URI
  -- ^ NOTE: All URIs in this module are assumed to be already percent-escaped
  }

data HistoryStateUpdate = HistoryStateUpdate
  { HistoryStateUpdate -> SerializedScriptValue
_historyStateUpdate_state :: SerializedScriptValue
  , HistoryStateUpdate -> Text
_historyStateUpdate_title :: Text
  , HistoryStateUpdate -> Maybe URI
_historyStateUpdate_uri :: Maybe URI
  -- ^ If Just, update the URI; otherwise leave it unchanged
  -- NOTE: All URIs in this module are assumed to be already percent-escaped
  }

data HistoryCommand
   = HistoryCommand_PushState HistoryStateUpdate
   | HistoryCommand_ReplaceState HistoryStateUpdate

runHistoryCommand :: MonadJSM m => History -> HistoryCommand -> m ()
runHistoryCommand :: History -> HistoryCommand -> m ()
runHistoryCommand history :: History
history = \case
  HistoryCommand_PushState su :: HistoryStateUpdate
su -> History -> SerializedScriptValue -> Text -> Maybe String -> m ()
forall (m :: * -> *) data' title url.
(MonadDOM m, ToJSVal data', ToJSString title, ToJSString url) =>
History -> data' -> title -> Maybe url -> m ()
History.pushState History
history
    (HistoryStateUpdate -> SerializedScriptValue
_historyStateUpdate_state HistoryStateUpdate
su)
    (HistoryStateUpdate -> Text
_historyStateUpdate_title HistoryStateUpdate
su)
    (URI -> String
forall a. Show a => a -> String
show (URI -> String) -> Maybe URI -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HistoryStateUpdate -> Maybe URI
_historyStateUpdate_uri HistoryStateUpdate
su)
  HistoryCommand_ReplaceState su :: HistoryStateUpdate
su -> History -> SerializedScriptValue -> Text -> Maybe String -> m ()
forall (m :: * -> *) data' title url.
(MonadDOM m, ToJSVal data', ToJSString title, ToJSString url) =>
History -> data' -> title -> Maybe url -> m ()
History.replaceState History
history
    (HistoryStateUpdate -> SerializedScriptValue
_historyStateUpdate_state HistoryStateUpdate
su)
    (HistoryStateUpdate -> Text
_historyStateUpdate_title HistoryStateUpdate
su)
    (URI -> String
forall a. Show a => a -> String
show (URI -> String) -> Maybe URI -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HistoryStateUpdate -> Maybe URI
_historyStateUpdate_uri HistoryStateUpdate
su)

getLocationUriAuth :: MonadJSM m => Location -> m URIAuth
getLocationUriAuth :: Location -> m URIAuth
getLocationUriAuth location :: Location
location = String -> String -> String -> URIAuth
URIAuth "" -- Username and password don't seem to be available in most browsers
  (String -> String -> URIAuth) -> m String -> m (String -> URIAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHostname Location
location
  m (String -> URIAuth) -> m String -> m URIAuth
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> String
appendColonIfNotEmpty (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPort Location
location)
  where appendColonIfNotEmpty :: String -> String
appendColonIfNotEmpty = \case
          "" -> ""
          x :: String
x -> ":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x

getLocationUri :: MonadJSM m => Location -> m URI
getLocationUri :: Location -> m URI
getLocationUri location :: Location
location = String -> Maybe URIAuth -> String -> String -> String -> URI
URI
  (String -> Maybe URIAuth -> String -> String -> String -> URI)
-> m String
-> m (Maybe URIAuth -> String -> String -> String -> URI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getProtocol Location
location
  m (Maybe URIAuth -> String -> String -> String -> URI)
-> m (Maybe URIAuth) -> m (String -> String -> String -> URI)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> m URIAuth -> m (Maybe URIAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m URIAuth
forall (m :: * -> *). MonadJSM m => Location -> m URIAuth
getLocationUriAuth Location
location)
  m (String -> String -> String -> URI)
-> m String -> m (String -> String -> URI)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPathname Location
location
  m (String -> String -> URI) -> m String -> m (String -> URI)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getSearch Location
location
  m (String -> URI) -> m String -> m URI
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHash Location
location

manageHistory :: (MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m)) => Event t HistoryCommand -> m (Dynamic t HistoryItem)
manageHistory :: Event t HistoryCommand -> m (Dynamic t HistoryItem)
manageHistory runCmd :: Event t HistoryCommand
runCmd = do
  Window
window <- m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  Location
location <- Window -> m Location
forall (m :: * -> *). MonadDOM m => Window -> m Location
Window.getLocation Window
window
  History
history <- Window -> m History
forall (m :: * -> *). MonadDOM m => Window -> m History
Window.getHistory Window
window
  let getCurrentHistoryItem :: JSM HistoryItem
getCurrentHistoryItem = SerializedScriptValue -> URI -> HistoryItem
HistoryItem
        (SerializedScriptValue -> URI -> HistoryItem)
-> JSM SerializedScriptValue -> JSM (URI -> HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> History -> JSM SerializedScriptValue
forall (m :: * -> *).
MonadDOM m =>
History -> m SerializedScriptValue
History.getState History
history
        JSM (URI -> HistoryItem) -> JSM URI -> JSM HistoryItem
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> JSM URI
forall (m :: * -> *). MonadJSM m => Location -> m URI
getLocationUri Location
location
  HistoryItem
item0 <- JSM HistoryItem -> m HistoryItem
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM JSM HistoryItem
getCurrentHistoryItem
  Event t HistoryItem
itemSetInternal <- Event t (Performable m HistoryItem) -> m (Event t HistoryItem)
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m HistoryItem) -> m (Event t HistoryItem))
-> Event t (Performable m HistoryItem) -> m (Event t HistoryItem)
forall a b. (a -> b) -> a -> b
$ Event t HistoryCommand
-> (HistoryCommand -> Performable m HistoryItem)
-> Event t (Performable m HistoryItem)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t HistoryCommand
runCmd ((HistoryCommand -> Performable m HistoryItem)
 -> Event t (Performable m HistoryItem))
-> (HistoryCommand -> Performable m HistoryItem)
-> Event t (Performable m HistoryItem)
forall a b. (a -> b) -> a -> b
$ \cmd :: HistoryCommand
cmd -> JSM HistoryItem -> Performable m HistoryItem
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM HistoryItem -> Performable m HistoryItem)
-> JSM HistoryItem -> Performable m HistoryItem
forall a b. (a -> b) -> a -> b
$ do
    History -> HistoryCommand -> JSM ()
forall (m :: * -> *).
MonadJSM m =>
History -> HistoryCommand -> m ()
runHistoryCommand History
history HistoryCommand
cmd
    JSM HistoryItem
getCurrentHistoryItem
  Event t HistoryItem
itemSetExternal <- Window
-> (Window -> EventM Window PopStateEvent () -> JSM (JSM ()))
-> EventM Window PopStateEvent HistoryItem
-> m (Event t HistoryItem)
forall t (m :: * -> *) e event a.
(TriggerEvent t m, MonadJSM m) =>
e
-> (e -> EventM e event () -> JSM (JSM ()))
-> EventM e event a
-> m (Event t a)
wrapDomEvent Window
window (Window
-> EventName Window PopStateEvent
-> EventM Window PopStateEvent ()
-> JSM (JSM ())
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> EventM t e () -> JSM (JSM ())
`DOM.on` EventName Window PopStateEvent
forall self.
(IsWindowEventHandlers self, IsEventTarget self) =>
EventName self PopStateEvent
DOM.popState) (EventM Window PopStateEvent HistoryItem
 -> m (Event t HistoryItem))
-> EventM Window PopStateEvent HistoryItem
-> m (Event t HistoryItem)
forall a b. (a -> b) -> a -> b
$ do
    PopStateEvent
e <- EventM Any PopStateEvent PopStateEvent
forall t e. EventM t e e
DOM.event
    SerializedScriptValue -> URI -> HistoryItem
HistoryItem
      (SerializedScriptValue -> URI -> HistoryItem)
-> ReaderT PopStateEvent DOM SerializedScriptValue
-> ReaderT PopStateEvent DOM (URI -> HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JSVal -> SerializedScriptValue
SerializedScriptValue (JSVal -> SerializedScriptValue)
-> ReaderT PopStateEvent DOM JSVal
-> ReaderT PopStateEvent DOM SerializedScriptValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PopStateEvent -> ReaderT PopStateEvent DOM JSVal
forall (m :: * -> *). MonadDOM m => PopStateEvent -> m JSVal
PopStateEvent.getState PopStateEvent
e)
      ReaderT PopStateEvent DOM (URI -> HistoryItem)
-> ReaderT PopStateEvent DOM URI
-> EventM Window PopStateEvent HistoryItem
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> ReaderT PopStateEvent DOM URI
forall (m :: * -> *). MonadJSM m => Location -> m URI
getLocationUri Location
location
  HistoryItem -> Event t HistoryItem -> m (Dynamic t HistoryItem)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn HistoryItem
item0 (Event t HistoryItem -> m (Dynamic t HistoryItem))
-> Event t HistoryItem -> m (Dynamic t HistoryItem)
forall a b. (a -> b) -> a -> b
$ [Event t HistoryItem] -> Event t HistoryItem
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Event t HistoryItem
itemSetInternal, Event t HistoryItem
itemSetExternal]
--TODO: Handle title setting better

manageHistory'
  :: (MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m))
  => Event t ()
  -- ^ Don't do anything until this event has fired
  -> Event t HistoryCommand
  -> m (Dynamic t HistoryItem)
manageHistory' :: Event t () -> Event t HistoryCommand -> m (Dynamic t HistoryItem)
manageHistory' switchover :: Event t ()
switchover runCmd :: Event t HistoryCommand
runCmd = do
  Window
window <- m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  Location
location <- Window -> m Location
forall (m :: * -> *). MonadDOM m => Window -> m Location
Window.getLocation Window
window
  History
history <- Window -> m History
forall (m :: * -> *). MonadDOM m => Window -> m History
Window.getHistory Window
window
  let getCurrentHistoryItem :: JSM HistoryItem
getCurrentHistoryItem = SerializedScriptValue -> URI -> HistoryItem
HistoryItem
        (SerializedScriptValue -> URI -> HistoryItem)
-> JSM SerializedScriptValue -> JSM (URI -> HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> History -> JSM SerializedScriptValue
forall (m :: * -> *).
MonadDOM m =>
History -> m SerializedScriptValue
History.getState History
history
        JSM (URI -> HistoryItem) -> JSM URI -> JSM HistoryItem
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> JSM URI
forall (m :: * -> *). MonadJSM m => Location -> m URI
getLocationUri Location
location
  HistoryItem
item0 <- JSM HistoryItem -> m HistoryItem
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM JSM HistoryItem
getCurrentHistoryItem
  Event t HistoryItem
itemSetExternal' <- Window
-> (Window -> EventM Window PopStateEvent () -> JSM (JSM ()))
-> EventM Window PopStateEvent HistoryItem
-> m (Event t HistoryItem)
forall t (m :: * -> *) e event a.
(TriggerEvent t m, MonadJSM m) =>
e
-> (e -> EventM e event () -> JSM (JSM ()))
-> EventM e event a
-> m (Event t a)
wrapDomEvent Window
window (Window
-> EventName Window PopStateEvent
-> EventM Window PopStateEvent ()
-> JSM (JSM ())
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> EventM t e () -> JSM (JSM ())
`DOM.on` EventName Window PopStateEvent
forall self.
(IsWindowEventHandlers self, IsEventTarget self) =>
EventName self PopStateEvent
DOM.popState) (EventM Window PopStateEvent HistoryItem
 -> m (Event t HistoryItem))
-> EventM Window PopStateEvent HistoryItem
-> m (Event t HistoryItem)
forall a b. (a -> b) -> a -> b
$ do
    PopStateEvent
e <- EventM Any PopStateEvent PopStateEvent
forall t e. EventM t e e
DOM.event
    SerializedScriptValue -> URI -> HistoryItem
HistoryItem
      (SerializedScriptValue -> URI -> HistoryItem)
-> ReaderT PopStateEvent DOM SerializedScriptValue
-> ReaderT PopStateEvent DOM (URI -> HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JSVal -> SerializedScriptValue
SerializedScriptValue (JSVal -> SerializedScriptValue)
-> ReaderT PopStateEvent DOM JSVal
-> ReaderT PopStateEvent DOM SerializedScriptValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PopStateEvent -> ReaderT PopStateEvent DOM JSVal
forall (m :: * -> *). MonadDOM m => PopStateEvent -> m JSVal
PopStateEvent.getState PopStateEvent
e)
      ReaderT PopStateEvent DOM (URI -> HistoryItem)
-> ReaderT PopStateEvent DOM URI
-> EventM Window PopStateEvent HistoryItem
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> ReaderT PopStateEvent DOM URI
forall (m :: * -> *). MonadJSM m => Location -> m URI
getLocationUri Location
location
  let f :: (Bool, Maybe a) -> These a () -> (Maybe (Bool, Maybe a), Maybe a)
      f :: (Bool, Maybe a) -> These a () -> (Maybe (Bool, Maybe a), Maybe a)
f (switched :: Bool
switched, acc :: Maybe a
acc) = \case
        This change :: a
change
          | Bool
switched -> (Maybe (Bool, Maybe a)
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just a
change)
          | Bool
otherwise -> ((Bool, Maybe a) -> Maybe (Bool, Maybe a)
forall a. a -> Maybe a
Just (Bool
switched, a -> Maybe a
forall a. a -> Maybe a
Just a
change), Maybe a
forall a. Maybe a
Nothing)
        That () -> ((Bool, Maybe a) -> Maybe (Bool, Maybe a)
forall a. a -> Maybe a
Just (Bool
True, Maybe a
forall a. Maybe a
Nothing), Maybe a
acc)
        These change :: a
change () -> ((Bool, Maybe a) -> Maybe (Bool, Maybe a)
forall a. a -> Maybe a
Just (Bool
True, Maybe a
forall a. Maybe a
Nothing), a -> Maybe a
forall a. a -> Maybe a
Just a
change)
  -- Accumulate the events before switchover
  (_, cmd' :: Event t (Either HistoryCommand HistoryItem)
cmd') <- ((Bool, Maybe (Either HistoryCommand HistoryItem))
 -> These (Either HistoryCommand HistoryItem) ()
 -> (Maybe (Bool, Maybe (Either HistoryCommand HistoryItem)),
     Maybe (Either HistoryCommand HistoryItem)))
-> (Bool, Maybe (Either HistoryCommand HistoryItem))
-> Event t (These (Either HistoryCommand HistoryItem) ())
-> m (Behavior t (Bool, Maybe (Either HistoryCommand HistoryItem)),
      Event t (Either HistoryCommand HistoryItem))
forall k (t :: k) (m :: * -> *) a b c.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> (Maybe a, Maybe c))
-> a -> Event t b -> m (Behavior t a, Event t c)
mapAccumMaybeB (Bool, Maybe (Either HistoryCommand HistoryItem))
-> These (Either HistoryCommand HistoryItem) ()
-> (Maybe (Bool, Maybe (Either HistoryCommand HistoryItem)),
    Maybe (Either HistoryCommand HistoryItem))
forall a.
(Bool, Maybe a) -> These a () -> (Maybe (Bool, Maybe a), Maybe a)
f (Bool
False, Maybe (Either HistoryCommand HistoryItem)
forall a. Maybe a
Nothing) (Event t (These (Either HistoryCommand HistoryItem) ())
 -> m (Behavior t (Bool, Maybe (Either HistoryCommand HistoryItem)),
       Event t (Either HistoryCommand HistoryItem)))
-> Event t (These (Either HistoryCommand HistoryItem) ())
-> m (Behavior t (Bool, Maybe (Either HistoryCommand HistoryItem)),
      Event t (Either HistoryCommand HistoryItem))
forall a b. (a -> b) -> a -> b
$ Event t (Either HistoryCommand HistoryItem)
-> Event t ()
-> Event t (These (Either HistoryCommand HistoryItem) ())
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align ([Event t (Either HistoryCommand HistoryItem)]
-> Event t (Either HistoryCommand HistoryItem)
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [HistoryCommand -> Either HistoryCommand HistoryItem
forall a b. a -> Either a b
Left (HistoryCommand -> Either HistoryCommand HistoryItem)
-> Event t HistoryCommand
-> Event t (Either HistoryCommand HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t HistoryCommand
runCmd, HistoryItem -> Either HistoryCommand HistoryItem
forall a b. b -> Either a b
Right (HistoryItem -> Either HistoryCommand HistoryItem)
-> Event t HistoryItem
-> Event t (Either HistoryCommand HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t HistoryItem
itemSetExternal']) Event t ()
switchover
  let (itemSetInternal' :: Event t HistoryCommand
itemSetInternal', itemSetExternal :: Event t HistoryItem
itemSetExternal) = Event t (Either HistoryCommand HistoryItem)
-> (Event t HistoryCommand, Event t HistoryItem)
forall k (t :: k) a b.
Reflex t =>
Event t (Either a b) -> (Event t a, Event t b)
fanEither Event t (Either HistoryCommand HistoryItem)
cmd'
  Event t HistoryItem
itemSetInternal <- Event t (Performable m HistoryItem) -> m (Event t HistoryItem)
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m HistoryItem) -> m (Event t HistoryItem))
-> Event t (Performable m HistoryItem) -> m (Event t HistoryItem)
forall a b. (a -> b) -> a -> b
$ Event t HistoryCommand
-> (HistoryCommand -> Performable m HistoryItem)
-> Event t (Performable m HistoryItem)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t HistoryCommand
itemSetInternal' ((HistoryCommand -> Performable m HistoryItem)
 -> Event t (Performable m HistoryItem))
-> (HistoryCommand -> Performable m HistoryItem)
-> Event t (Performable m HistoryItem)
forall a b. (a -> b) -> a -> b
$ \cmd :: HistoryCommand
cmd -> JSM HistoryItem -> Performable m HistoryItem
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM HistoryItem -> Performable m HistoryItem)
-> JSM HistoryItem -> Performable m HistoryItem
forall a b. (a -> b) -> a -> b
$ do
    History -> HistoryCommand -> JSM ()
forall (m :: * -> *).
MonadJSM m =>
History -> HistoryCommand -> m ()
runHistoryCommand History
history HistoryCommand
cmd
    JSM HistoryItem
getCurrentHistoryItem
  HistoryItem -> Event t HistoryItem -> m (Dynamic t HistoryItem)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn HistoryItem
item0 (Event t HistoryItem -> m (Dynamic t HistoryItem))
-> Event t HistoryItem -> m (Dynamic t HistoryItem)
forall a b. (a -> b) -> a -> b
$ [Event t HistoryItem] -> Event t HistoryItem
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Event t HistoryItem
itemSetInternal, Event t HistoryItem
itemSetExternal]
--TODO: Handle title setting better