Support full pushState/replaceState API

[3noch]

Pushing a new state should allow:

1. Choosing between pushing or replacing.
2. Saving arbitrary data.

[3noch]

Here's the raw code for this:

import           Data.Text                   (Text)
import           GHC.Generics                (Generic)
import           GHCJS.DOM                   (currentWindowUnchecked)
import           GHCJS.DOM.EventTarget       (dispatchEvent_)
import qualified GHCJS.DOM.History           as Dom
import           GHCJS.DOM.Location          (reload)
import           GHCJS.DOM.PopStateEvent     (newPopStateEvent)
import           GHCJS.DOM.Types             (JSM, MonadJSM, ToJSVal, liftJSM, pFromJSVal)
import qualified GHCJS.DOM.Types             as Dom
import           GHCJS.DOM.Window            (getHistory, getLocation)
import qualified Language.Javascript.JSaddle as JS
import           Reflex.Dom.Core

#ifdef ghcjs_HOST_OS
#else
import Control.Lens.Operators             ((^.))
import Language.Javascript.JSaddle.Object (js, js1, js2, jsg)
#endif


tellRedirectLocallyAs
  :: (MonadJSM (Performable m), PerformEvent t m, PostBuild t m, RouteWriter t Text m)
  => [Text] -> m ()
tellRedirectLocallyAs segments = do
  nowEv <- getPostBuild
  changePageState ((ReplaceHistory, Just path, Nothing :: Maybe Text) <$ nowEv)
  where
    path = "#" <> T.intercalate "/" segments

data PageChangeType = PushHistory | ReplaceHistory deriving (Bounded, Enum, Eq, Generic, Show)

changePageState
  :: (MonadJSM (Performable m), PerformEvent t m, ToJSVal state)
  => Event t (PageChangeType, Maybe Text, Maybe state) -> m ()
changePageState ev = performEvent_ (callJs <$> ev)
  where
    callJs (changeType, newUrl, state) = do
      window  <- currentWindowUnchecked
      history <- getHistory window
      let
        fn = case changeType of
          PushHistory    -> Dom.pushState
          ReplaceHistory -> Dom.replaceState

      fn history state (t_ "") newUrl
      liftJSM $ dispatchEvent' window

dispatchEvent' :: Dom.Window -> JSM ()
dispatchEvent' window = do
  obj@(JS.Object o) <- JS.create
  JS.objSetPropertyByName obj (t_ "cancelable") True
  JS.objSetPropertyByName obj (t_ "bubbles")    True
  JS.objSetPropertyByName obj (t_ "view")       window
  event <- newPopStateEvent (t_ "popstate") $ Just $ pFromJSVal o
  dispatchEvent_ window event